(*---------------------------------------------------------------------------
    This file axiomatises the inference rules of an intuitionistic logic and
    offers some parametric instances to make it straightforward to create a new
    logic that satisfies those axioms. The purpose is to factor out what the
    assertion logic and specification logic of a separation logic framework
    have in common.
  ---------------------------------------------------------------------------*)
Require Import Setoid Morphisms RelationClasses Program.Basics Omega.
Require Import Equiv.

Set Implicit Arguments.
Unset Strict Implicit.
Set Maximal Implicit Insertion.

(* The natural numbers in descending order. *)
Global Instance ge_Pre: PreOrder ge.
Proof. repeat constructor. hnf. eauto with arith. Qed.

(* These tactics are meant to relieve the user from remembering morphism names.
   In most cases they will apply the most general morphism for the arity
   requested. *)
(* TODO: move this somewhere more general. *)
Ltac postcancel := unfold Basics.flip; trivial.
Ltac cancel1 :=
  apply (proper_prf (Proper := _: Proper (_ ==> _) _));
  postcancel.
Ltac cancel2 :=
  apply (proper_prf (Proper := _: Proper (_ ==> _ ==> _) _));
  postcancel.
Ltac cancel3 :=
  apply (proper_prf (Proper := _: Proper (_ ==> _ ==> _ ==> _) _));
  postcancel.

Class Inhabited A := { cinhabited : inhabited A}.

Instance inhabitedNat: Inhabited nat. Proof. split; split; apply 0. Qed.
Instance inhabitedBool: Inhabited bool. Proof. split; split; apply true. Qed.

Generalizable Variables Frm.

(* Logical connectives *)
Class ILogicOps Frm := {
  lentails: relation Frm;
  ltrue: Frm;
  lfalse: Frm;
  limpl: Frm -> Frm -> Frm;
  land: Frm -> Frm -> Frm;
  lor: Frm -> Frm -> Frm;
  lforall: forall {T}, (T -> Frm) -> Frm;
  lexists: forall {T}, (T -> Frm) -> Frm
}.

(* These notations have to sit strictly between level 80 (precendence of /\)
   and level 70 (precedence of =). *)
Infix "|--"  := lentails (at level 79, no associativity).
Infix "//\\"   := land (at level 75, right associativity).
Infix "\\//"   := lor (at level 76, right associativity).
Infix "-->>"   := limpl (at level 77, right associativity).
Notation "'Forall' x : T , p" :=
  (lforall (fun x : T => p)) (at level 78, x ident, right associativity).
Notation "'Forall' x , p" :=
  (lforall (fun x => p)) (at level 78, x ident, right associativity).
Notation "'Exists' x : T , p" :=
  (lexists (fun x : T => p)) (at level 78, x ident, right associativity).
Notation "'Exists' x , p" :=
  (lexists (fun x => p)) (at level 78, x ident, right associativity).

(* Axioms of an intuitionistic logic, presented in a sequent calculus style
   with singleton contexts on the left of the turnstile. This form is
   particularly suited for the undisciplined context manipulation that tends to
   happen in separation logic.

   Every connective has a number of L-rules and a number of R-rules describing
   what can be done to prove a goal that has the connective as the head symbol
   of the left, respectively right, side of a turnstile. The notable exception
   to this pattern is implication, which is required to be the right adjoint of
   conjunction. This makes singleton contexts work. *)
Class ILogic Frm {ILOps: ILogicOps Frm} := {
  lentailsPre:> PreOrder lentails;
  ltrueR: forall C, C |-- ltrue;
  lfalseL: forall C, lfalse |-- C;
  lforallL: forall T x (P: T -> Frm) C, P x |-- C -> lforall P |-- C;
  lforallR: forall T (P: T -> Frm) C, (forall x, C |-- P x) -> C |-- lforall P;
  lexistsL: forall T (P: T -> Frm) C, (forall x, P x |-- C) -> lexists P |-- C;
  lexistsR: forall T x (P: T -> Frm) C, C |-- P x -> C |-- lexists P;
  landL1: forall P Q C, P |-- C  ->  P //\\ Q |-- C;
  landL2: forall P Q C, Q |-- C  ->  P //\\ Q |-- C;
  lorR1:  forall P Q C, C |-- P  ->  C |-- P \\// Q;
  lorR2:  forall P Q C, C |-- Q  ->  C |-- P \\// Q;
  landR:  forall P Q C, C |-- P  ->  C |-- Q  ->  C |-- P //\\ Q;
  lorL:   forall P Q C, P |-- C  ->  Q |-- C  ->  P \\// Q |-- C;
  landAdj: forall P Q C, C |-- (P -->> Q) -> C //\\ P |-- Q;
  limplAdj: forall P Q C, C //\\ P |-- Q -> C |-- (P -->> Q)
}.
Implicit Arguments ILogic [[ILOps]].
Implicit Arguments lforallL [[ILOps] [Frm] [ILogic] [T] [P] [C]].
Implicit Arguments lexistsR [[ILOps] [Frm] [ILogic] [T] [P] [C]].

Notation "|-- P" := (ltrue |-- P) (at level 85, no associativity).
Hint Extern 0 (?x |-- ?x) => reflexivity.
Hint Extern 0 (_ |-- ltrue) => apply ltrueR.
Hint Extern 0 (lfalse |-- _) => apply lfalseL.
Hint Extern 0 (?P |-- ?Q) => (is_evar P; reflexivity) || (is_evar Q; reflexivity).

Section ILogicExtra.
  Context `{IL: ILogic Frm}.

  Definition lequiv P Q := P |-- Q /\ Q |-- P.
  Definition lpropand (p: Prop) Q := Exists _: p, Q.
  Definition lpropimpl (p: Prop) Q := Forall _: p, Q.

  Global Instance lequivEquiv : Equiv Frm | 0 := { equiv := lequiv }.
End ILogicExtra.

Infix "/\\" := lpropand (at level 75, right associativity).
Infix "->>" := lpropimpl (at level 77, right associativity).
Infix "-|-"  := lequiv (at level 85, no associativity).

Hint Extern 0 (?x -|- ?x) => reflexivity.
Hint Extern 0 (?P -|- ?Q) => (is_evar P; reflexivity) || (is_evar Q; reflexivity).

(* TODO: also add lforwardR. *)
Lemma lforwardL {Frm} `{IL: ILogic Frm} {Q R}:
    Q |-- R -> forall P G,
    P |-- Q ->
    (P |-- R -> G) ->
    G.
Proof. intros HQR ** HPQ HG. apply HG. etransitivity; eassumption. Qed.

Tactic Notation "lforwardL" hyp(H) :=
  eapply (lforwardL H); clear H; [|intros H].

Section ILogicMorphisms.
  Context `{IL: ILogic Frm}.

  Global Instance lequivEqu : Equivalence lequiv.
  Proof.
    unfold lequiv. constructor; red.
    + split; reflexivity.
    + intuition.
    + intros P Q R [HPQ HQP] [HQR HRQ];
      split; etransitivity; eassumption.
  Qed.

  Global Instance lequiv_lentails : subrelation lequiv lentails.
  Proof. firstorder. Qed.
  Global Instance lequiv_inverse_lentails: subrelation lequiv (inverse lentails).
  Proof. firstorder. Qed.

  Global Instance lforall_lentails_m T:
    Proper (pointwise_relation T lentails ++> lentails) lforall.
  Proof.
    intros P P' HP. apply lforallR; intro x;  apply lforallL with x.
    rewrite HP; reflexivity.
  Qed.

  Global Instance lforall_lequiv_m T:
    Proper (pointwise_relation T lequiv ++> lequiv) lforall.
  Proof.
    intros P P' HP; split; apply lforall_lentails_m; intro x; apply HP.
  Qed.

  Global Instance lexists_lentails_m T:
    Proper (pointwise_relation T lentails ++> lentails) lexists.
  Proof.
    intros P P' HP. apply lexistsL; intro x; apply lexistsR with x.
    rewrite HP; reflexivity.
  Qed.

  Global Instance lexists_lequiv_m T:
    Proper (pointwise_relation T lequiv ++> lequiv) lexists.
  Proof.
    intros P P' HP; split; apply lexists_lentails_m; intro x; apply HP.
  Qed.

  Global Instance : Proper (lequiv ==> lequiv ==> iff) lequiv.
  Proof.
    intuition.
  Qed.

  Global Instance lequiv_lentails_m : Proper (lequiv ==> lequiv ==> iff) lentails.
  Proof.
    cbv; intuition; (etransitivity; [etransitivity|]); eassumption.
  Qed.

  Global Instance lentails_lentails_m: Proper (lentails --> lentails ++> impl) lentails.
  Proof.
    intuition.
  Qed.

  Global Instance land_lentails_m:
    Proper (lentails ++> lentails ++> lentails) land.
  Proof.
    intros P P' HP Q Q' HQ.
    apply landR; [apply landL1 | apply landL2]; assumption.
  Qed.

  Global Instance land_lequiv_m:
    Proper (lequiv ==> lequiv ==> lequiv) land.
  Proof.
    intros P P' HP Q Q' HQ.
    split; apply land_lentails_m; (apply HP || apply HQ).
  Qed.

  Global Instance lor_lentails_m:
    Proper (lentails ++> lentails ++> lentails) lor.
  Proof.
    intros P P' HP Q Q' HQ.
    apply lorL; [apply lorR1 | apply lorR2]; assumption.
  Qed.

  Global Instance lor_lequiv_m:
    Proper (lequiv ==> lequiv ==> lequiv) lor.
  Proof.
    intros P P' HP Q Q' HQ.
    split; apply lor_lentails_m; (apply HP || apply HQ).
  Qed.

  Global Instance limpl_lentails_m:
    Proper (lentails --> lentails ++> lentails) limpl.
  Proof.
    intros P P' HP Q Q' HQ; red in HP.
    apply limplAdj; rewrite <- HQ, HP; apply landAdj; reflexivity.
  Qed.

  Global Instance limpl_lequiv_m:
    Proper (lequiv ==> lequiv ==> lequiv) limpl.
  Proof.
    intros P P' HP Q Q' HQ.
    split; apply limpl_lentails_m; (apply HP || apply HQ).
  Qed.

  Global Instance lpropand_lentails_m:
    Proper (impl ++> lentails ++> lentails) lpropand.
  Proof.
    intros p p' Hp Q Q' HQ.
    apply lexistsL; intro H. apply lexistsR; [apply Hp|]; assumption.
  Qed.

  Global Instance lpropand_lequiv_m:
    Proper (iff ==> lequiv ==> lequiv) lpropand.
  Proof.
    intros p p' Hp Q Q' HQ.
    split; cancel2; unfold impl; (apply Hp || apply HQ).
  Qed.

  Global Instance lpropimpl_lentails_m:
    Proper (impl --> lentails ++> lentails) lpropimpl.
  Proof.
    intros p p' Hp Q Q' HQ.
    apply lforallR; intro H. apply lforallL; [apply Hp|]; assumption.
  Qed.

  Global Instance lpropimpl_lequiv_m:
    Proper (iff ==> lequiv ==> lequiv) lpropimpl.
  Proof.
    intros p p' Hp Q Q' HQ.
    split; cancel2; unfold flip, impl; (apply Hp || apply HQ).
  Qed.

End ILogicMorphisms.

Section ILogicFacts.
  Context `{IL: ILogic Frm}.

  (* Experiments with proof search. *)
  Ltac landR :=
    repeat match goal with
    | |- _ |-- _ //\\ _ => apply landR
    end.

  Ltac landL :=
    repeat match goal with
    | |- ?L1 //\\ ?L2 |-- ?R =>
        match L1 with
        | context [R] => apply landL1
        | _ =>
          match L2 with
          | context [R] => apply landL2
          end
        end
    end.

  Lemma landC P Q: P //\\ Q -|- Q //\\ P.
  Proof. split; landR; landL; reflexivity. Qed.

  Lemma landA P Q R: (P //\\ Q) //\\ R -|- P //\\ (Q //\\ R).
  Proof. split; landR; landL; reflexivity. Qed.

  (* Derivable but useful *)
  Lemma lpropandTrue P : True /\\ P -|- P.
  Proof. unfold lpropand. split; [apply lexistsL | apply lexistsR]; trivial. Qed.

  Lemma lpropandFalse P : False /\\ P -|- lfalse.
  Proof. unfold lpropand. split; [apply lexistsL |]; intuition. Qed.

  (* Left-rule for limpl. This breaks the discipline of the ILogic presentation
     since the implication is not strictly the top symbol of the left-hand side,
     but it remains a convenient rule. *)
  Lemma limplL P Q CL CR (HP: CL |-- P) (HR: Q //\\ CL |-- CR) :
    (P -->> Q) //\\ CL |-- CR.
  Proof.
    rewrite <-HR, <-HP. apply landR; [apply landAdj |apply landL2]; reflexivity.
  Qed.

  Lemma lpropandL (p: Prop) Q C (H: p -> Q |-- C) :
    p /\\ Q |-- C.
  Proof. apply lexistsL; intro Hp. apply H; assumption. Qed.

  Lemma lpropandR C (p: Prop) Q (Hp: p) (HQ: C |-- Q) :
    C |-- p /\\ Q.
  Proof. apply lexistsR with Hp; assumption. Qed.

  Lemma lpropimplL (p: Prop) (Q C: Frm) (Hp: p) (HQ: Q |-- C) :
    p ->> Q |-- C.
  Proof. apply lforallL with Hp; assumption. Qed.

  Lemma lpropimplR C (p: Prop) Q (H: p -> C |-- Q) :
    C |-- p ->> Q.
  Proof. apply lforallR; intro Hp. apply H; assumption. Qed.

  (* Special case of limplAdj/landAdj when there is just ltrue on the lhs *)
  Lemma limplValid P Q:
    |-- P -->> Q <->
    P |-- Q.
  Proof.
    split; intro H.
    - etransitivity; [eapply landR; [apply ltrueR|reflexivity]|].
      apply landAdj; assumption.
    - apply limplAdj. apply landL2; assumption.
  Qed.

  Lemma landexistsD {A} (f : A -> Frm) (P : Frm) :
    (Exists a, f a) //\\ P -|- Exists a, (f a //\\ P).
  Proof.
    split.
    + apply landAdj; apply lexistsL; intro a;
      apply limplAdj; apply lexistsR with a; reflexivity.
    + apply lexistsL; intro a; apply landR.
      - apply landL1; apply lexistsR with a; reflexivity.
      - apply landL2; reflexivity.
  Qed.

  Lemma landforallDL {A} (f : A -> Frm) (P : Frm) :
    (Forall a, f a) //\\ P |-- Forall a, (f a //\\ P).
  Proof.
    apply lforallR; intro a; apply landR.
    + apply landL1; apply lforallL with a; reflexivity.
    + apply landL2; reflexivity.
  Qed.

  Lemma landforallDR {A} {H: Inhabited A} (f : A -> Frm) (P : Frm) :
    Forall a, (f a //\\ P) |-- (Forall a, f a) //\\ P.
  Proof.
    apply landR.
    + apply lforallR; intro a; apply lforallL with a; apply landL1; reflexivity.
    + destruct H as [[a]]. apply lforallL with a; apply landL2; reflexivity.
  Qed.

  Lemma lpropandexistsD {A} (f : A -> Frm) (P : Prop) :
    P /\\ (Exists a, f a) -|- Exists a, (P /\\ f a).
  Proof.
    split.
    + apply lpropandL; intro HP; apply lexistsL; intro a.
      apply lexistsR with a; apply lpropandR; auto.
    + apply lexistsL; intro a; apply lpropandL; intro HP; apply lpropandR; [assumption|].
      apply lexistsR with a; reflexivity.
  Qed.

  Lemma lpropandforallDL {A} (f : A -> Frm) (P : Prop) :
    P /\\ (Forall a, f a) |-- Forall a, (P /\\ f a).
  Proof.
    apply lpropandL; intro HP; apply lforallR; intro a; apply lpropandR; [assumption|].
    apply lforallL with a; reflexivity.
  Qed.

  Lemma lpropandforallDR {A} {H: Inhabited A} (f : A -> Frm) (P : Prop) :
    Forall a, (P /\\ f a) |-- P /\\ (Forall a, f a).
  Proof.
    assert ((P /\\ ltrue) //\\ (Forall a, f a) |-- P /\\ (Forall a, f a)) as H0.
    + apply landAdj. apply lpropandL; intros HP. apply limplAdj; apply landL2.
      apply lpropandR; [assumption|].
      apply lforallR; intro a; apply lforallL with a; reflexivity.
    + rewrite <- H0; apply landR.
      - destruct H as [[a]]; apply lforallL with a;
        apply lpropandL; intros; apply lpropandR; auto.
      - apply lforallR; intro a; apply lforallL with a;
        apply lpropandL; intros; reflexivity.
  Qed.

End ILogicFacts.

(* Most of the connectives in ILogicOps are redundant. They can be derived from
   lexists, lforall and limpl, and the choice of limpl is unique up to lequiv
   since it is an adjoint. *)
Section ILogicEquiv.
  Context `{IL: ILogic Frm}.

  Lemma land_is_forall P Q :
    P //\\ Q -|- Forall b : bool, if b then P else Q.
  Proof.
    split.
    - apply lforallR; intro x; destruct x.
      + apply landL1; reflexivity.
      + apply landL2; reflexivity.
    - apply landR.
      + apply lforallL with true; reflexivity.
      + apply lforallL with false; reflexivity.
  Qed.

  Lemma lor_is_exists P Q:
    P \\// Q -|- Exists b : bool, if b then P else Q.
  Proof.
    split.
    - apply lorL.
      + apply lexistsR with true; reflexivity.
      + apply lexistsR with false; reflexivity.
    - apply lexistsL; intro x; destruct x.
      + apply lorR1; reflexivity.
      + apply lorR2; reflexivity.
  Qed.

  Lemma ltrue_is_forall:
    ltrue -|- Forall x: Empty_set, Empty_set_rect _ x.
  Proof. split; [apply lforallR|]; intuition. Qed.

  Lemma lfalse_is_exists:
    lfalse -|- Exists x: Empty_set, Empty_set_rect _ x.
  Proof. split; [|apply lexistsL]; intuition. Qed.

End ILogicEquiv.

Section ILogicEmbed.
  Context {A} `{ILOpsA: ILogicOps A}.
  Context {B} `{ILOpsB: ILogicOps B}.

  Class EmbedOp := { embed : A -> B }.

  Class Embed {EmbOp: EmbedOp} := {
     embed_sound p q : p |-- q -> embed p |-- embed q;

     embedlforall T f : Forall x : T, embed (f x) -|- embed (Forall x : T, f x);
     embedlexists T f : Exists x : T, embed (f x) -|- embed (Exists x : T, f x);
     embedImpl a b : (embed a) -->> (embed b) -|- embed (a -->> b)
  }.
End ILogicEmbed.

Implicit Arguments EmbedOp [].
Implicit Arguments Embed [[ILOpsA] [ILOpsB] [EmbOp]].

Section ILogicEmbedFacts.
  Context {A B} `{HAB: Embed A B} {ILA: ILogic A} {ILB: ILogic B}.

  Global Instance embed_lentails_m :
    Proper (lentails ==> lentails) embed.
  Proof.
    intros a b Hab; apply embed_sound; assumption.
  Qed.

  Global Instance embed_lequiv_m :
    Proper (lequiv ==> lequiv) embed.
  Proof.
    intros a b Hab; split; destruct Hab; apply embed_sound; assumption.
  Qed.

  Lemma embedland a b : embed a //\\ embed b -|- embed (a //\\ b).
  Proof.
    do 2 rewrite land_is_forall; rewrite <- embedlforall; split;
    apply lforallR; intro x; apply lforallL with x;
    destruct x; reflexivity.
  Qed.

  Lemma embedlor a b : embed a \\// embed b -|- embed (a \\// b).
  Proof.
    do 2 rewrite lor_is_exists; erewrite <- embedlexists; split;
    apply lexistsL; intro x; apply lexistsR with x;
    destruct x; reflexivity.
  Qed.

  Lemma embedlfalse : embed lfalse -|- lfalse.
  Proof.
    rewrite lfalse_is_exists; erewrite <- embedlexists; split;
    [apply lexistsL; intro x; destruct x | apply lfalseL].
  Qed.

  Lemma embedltrue : embed ltrue -|- ltrue.
  Proof.
    rewrite ltrue_is_forall; rewrite <- embedlforall; split;
    [apply ltrueR | apply lforallR; intro x; destruct x].
  Qed.

End ILogicEmbedFacts.

(* Prop is an intuitionistic logic *)
Global Instance ILogicOps_Prop : ILogicOps Prop := {|
  lentails P Q := P -> Q;
  ltrue        := True;
  lfalse       := False;
  limpl    P Q := P -> Q;
  land     P Q := P /\ Q;
  lor      P Q := P \/ Q;
  lforall  T F := forall x:T, F x;
  lexists  T F := exists x:T, F x
|}.

Global Instance ILogic_Prop : ILogic Prop.
Proof.
  split; cbv; firstorder.
Qed.

(* Make the setoid system realize that these are the same things (in the
   direction that seems useful. *)
Instance: subrelation lentails Basics.impl.
Proof. reflexivity. Qed.
Instance: subrelation lequiv iff.
Proof. reflexivity. Qed.

(* Coq tends to unfold lentails on [simpl], which triggers unfolding of
   several other connectives. When that happens, the goal can become quite
   unreadable. The workaround is to make the definition of entailment and
   connectives opaque. If a module wants to unfold those definitions, it should
   do [Transparent IL?_Ops], where ? is Pre or Fun. *)


(* This program is free software; 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 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program 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 Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(**********************************************************************)
(*               Intensional Lambda Calculus                          *)
(*                                                                    *)
(* is implemented in Coq by adapting the implementation               *)
(* of Lambda Calculus from Project Coq                                *)
(* 2015                                                               *)
(**********************************************************************)

(**********************************************************************)
(*                      Closed.v                                      *)
(*                                                                    *)
(*                      Barry Jay                                     *)
(*                                                                    *)
(**********************************************************************)

Require Import Arith.
Require Import Lambda.Test.
Require Import Lambda.General.
Require Import Omega.
Require Import Max.
Require Import Lambda.Terms.
Require Import Lambda.Lambda_tactics.
Require Import Lambda.Substitution_term.

(* closed terms *)

Fixpoint maxvar (M: lambda) :=
match M with
| Ref i => S i
| App M1 M2 => max (maxvar M1) (maxvar M2)
| Abs N => pred (maxvar N)
end.

Lemma maxvar_lift_rec : forall M n k, maxvar M + k >= maxvar (lift_rec M n k) .
Proof.
induction M; split_all.
unfold relocate. elim(test n0 n); split_all; omega.
assert(pred (maxvar M) + k >= pred (maxvar M + k)) by omega.
assert(maxvar M + k >= maxvar (lift_rec M (S n) k)) by eapply2 IHM.
omega.
rewrite max_plus.
eapply2 max_monotonic.
Qed.

Lemma subst_decreases_maxvar :
forall M N k,  max (pred (maxvar M)) (maxvar N + k) >= maxvar(subst_rec M N k).
Proof.
induction M; split_all.
unfold insert_Ref.
elim(compare k n); split_all.
elim a; split_all.
assert(max n (maxvar N + k) >= n) by eapply2 max_is_max.
omega.
unfold lift.
elim(maxvar_lift_rec N 0 k); split_all.
eapply2 max_is_max.
assert(max n (S m) >= max n m) by (eapply2 max_monotonic; omega).
omega.
assert(max n (maxvar N + k) >= maxvar N + k) by eapply2 max_is_max.
omega.

(* 2 subgoals *)
assert(max (pred (pred (maxvar M))) (maxvar N + k) >= pred(max (pred (maxvar M)) (maxvar N + (S k)))).
rewrite max_pred.
eapply2 max_monotonic.
omega.
assert(max (pred (maxvar M)) (maxvar N + S k) >= maxvar (subst_rec M N (S k)))
by eapply2 IHM.
assert(pred (max (pred (maxvar M)) (maxvar N + S k)) >= pred (maxvar (subst_rec M N (S k)))) by omega.
omega.
(* 1 *)
rewrite max_pred.
assert(max(max (pred (maxvar M1)) (maxvar N + k) ) (max (pred (maxvar M2)) (maxvar N + k)) >= max (maxvar (subst_rec M1 N k)) (maxvar (subst_rec M2 N k))).
eapply2 max_monotonic.
assert(max (max (pred (maxvar M1)) (pred (maxvar M2))) (maxvar N + k)  >=
max(max (pred (maxvar M1)) (maxvar N + k) ) (max (pred (maxvar M2)) (maxvar N + k))).
2: omega.
eapply2 max_max2; eapply2 max_monotonic; eapply2 max_is_max.
Qed.

Definition decreases  (rank: lambda -> nat) (red:termred):=
forall M N, red M N -> rank M >= rank N.

Lemma decreases_multi_step:
forall rank red, decreases rank red -> decreases rank (multi_step red).
Proof.
red. intros rank red D M N R;  induction R; split_all.
assert(rank M >= rank N) by eapply2 D.
assert(rank N >= rank P) by eapply2 IHR.
omega.
Qed.

Lemma lift_rec_closed: forall M n, n>= maxvar M  -> forall k, lift_rec M n k = M.
Proof. induction M; split_all; subst; unfold lift; unfold lift_rec; fold lift_rec.
unfold relocate. elim(test n0 n); split_all; try noway.
rewrite IHM.  auto. omega.
assert(max (maxvar M1) (maxvar M2) >= maxvar M1) by eapply2 max_is_max.
assert(max (maxvar M1) (maxvar M2) >= maxvar M2) by eapply2 max_is_max.
rewrite IHM1; try omega; rewrite IHM2; try omega; congruence.
Qed.

Lemma lift_closed: forall M, maxvar M =0 -> forall k, lift k M = M.
Proof.  split_all; eapply2 lift_rec_closed. omega. Qed.

Lemma subst_rec_closed : forall M n, n>= maxvar M -> forall N, subst_rec M N n = M.
Proof.
induction M; split_all; subst.
unfold insert_Ref.
elim(compare n0 n); split_all; try noway.  elim a; split_all; try noway.
rewrite IHM; try omega; split_all.
assert(max (maxvar M1) (maxvar M2) >= maxvar M1) by eapply2 max_is_max.
assert(max (maxvar M1) (maxvar M2) >= maxvar M2) by eapply2 max_is_max.
rewrite IHM1; try omega; rewrite IHM2; try omega; split_all.
Qed.

Lemma maxvar_subst_rec: forall M k, maxvar M <= k -> forall N, subst_rec M N k = M.
Proof.
induction M; unfold subst_rec; fold subst_rec; split_all; subst.
unfold insert_Ref. elim(compare k n); split_all; try noway.
elim a; split_all; try noway.
rewrite IHM; split_all; omega.

assert(k>= maxvar M1 /\ k>= maxvar M2) by eapply2 max_max; split_all.
rewrite IHM1; split_all.
rewrite IHM2; split_all.
Qed.

Ltac max_l :=
match goal with
| |- max ?m ?n >= ?p =>
assert(max m n >= m) by eapply2 max_is_max;
cut(m >= p); split_all; try omega
end.
Ltac max_r :=
match goal with
| |- max ?m ?n >= ?p =>
assert(max m n >= n) by eapply2 max_is_max;
cut(n >= p); split_all; try omega
end.

(* restore ??

Lemma decreases_maxvar_lamF_red1: decreases maxvar lambda_red1.
(*
forall M N, lamF_red1 M N -> maxvar N <= maxvar M.
*)
Proof.
cut(forall M N, lambda_red1 M N -> maxvar N <= maxvar M).
split_all; red.

intros M N R; induction R; split_all; eauto; try (repeat (eapply2 max_monotonic); fail); try omega; repeat (eapply2 max_max2); try (max_r; fail); try (repeat max_l; fail).
(* 5 *)
unfold subst.
assert(max (pred (maxvar M)) (maxvar N + 0) >= maxvar(subst_rec M N 0)).
eapply2 subst_decreases_maxvar.
replace (maxvar N + 0) with (maxvar N) in H by omega.
omega.
(* 4 *)
max_l. max_r.
(* 3 *)
assert(max(maxvar M) (maxvar N) >= maxvar M) by max_l. omega.
(* 2 *)
max_l. max_l. eapply2 left_component_preserves_maxvar.
max_l. max_l. eapply2 right_component_preserves_maxvar.
Qed.

Lemma decreases_maxvar_lamF_red : decreases maxvar lambda_red.
Proof. eapply2 decreases_multi_step. eapply2 decreases_maxvar_lamF_red1. Qed.

*)


Require Import List Omega ZArith.Int.
Require Import Util EqDec DecSolve.
Require Import OrderedTypeEx MoreList.

Set Implicit Arguments.

(** * Definitions related to variables *)

(** ** A class for counted types *)
(** A counted type is a type for which an injection to the naturals exists *)
Class Counted (A : Type) := {
  counted     : A -> nat;
  counted_inj : forall (x y : A), counted x = counted y -> x = y;
  incc        : forall (x : A), nat -> A
}.

(** ** Variables *)
(* We take naturals directly as variables *)
Notation "'var'" := positive (only parsing).
Definition default_var : var := 1%positive.
Instance var_dec (x y:var) : Computable (x = y).
Proof.
  eapply Pos.eq_dec.
Qed.

(*
Definition var_to_nat (v:var) := v.

Coercion var_to_nat : nat >-> nat.
*)

Lemma var_eq_eq (x y : var)
  : _eq x y -> x = y.
Proof.
  inversion 1; eauto.
Qed.

(*Definition var : Type := nat.

Global Instance inst_defaulted_var : Defaulted var := Build_Defaulted default_var.
Global Instance inst_eq_dec_var : EqDec var eq := nat_eq_eqdec.
Global Program Instance inst_counted_var : Counted var :=
  Build_Counted (fun x => x) _ (fun x => fun y => x + y).
*)
(** ** Locations *)

Inductive loc : Type :=
  | LocI : nat -> loc.
Definition default_loc : loc := LocI 0.
Global Instance inst_eq_dec_loc : EqDec loc eq.
hnf; intros. destruct x,y. decide (n=n0).
subst; left; reflexivity.
right. intro. inversion H. eauto.
Defined.

Definition locN l :=
  match l with
    | LocI n => n
  end.

Lemma locN_inj (x y : loc)
  : locN x = locN y -> x = y.
Proof.
  destruct x,y; eauto.
Qed.

Definition locInc (l:loc) (d:nat) := match l with LocI n => LocI (d + n) end.

Global Instance inst_counted_loc : Counted loc :=
  Build_Counted locN locN_inj locInc.

(** ** Labels **)
(* Labels are used as identifiers for blocks *)
Inductive lab : Type :=
| LabI : nat -> lab.

Definition default_lab := LabI 0.

Lemma eq_dec_lab (x y : lab) :
  {x=y} + {x<>y}.
Proof.
  repeat decide equality.
Defined.

(** *** equality of labels is decidable *)
Global Instance inst_eq_dec_lab : EqDec lab eq := {
  equiv_dec := eq_dec_lab
}.

(** *** labels are counted *)
Coercion labN (x : lab) : nat :=
  match x with
  | LabI x => x
  end.

Lemma labN_inj (x y : lab)
  : labN x = labN y -> x = y.
Proof.
  destruct x,y; eauto.
Qed.

Smpl Add 50
     match goal with
     | [ H : labN ?x = labN ?y |- _ ] => eapply labN_inj in H; first [is_var x; subst x | is_var y; subst y| idtac ]
     end : inv_get.

Definition labInc (l:lab) (d:nat) := match l with LabI n => LabI (d + n) end.

Global Instance inst_counted_lab : Counted lab :=
  Build_Counted labN labN_inj labInc.

Lemma counted_labI (n : nat) :
  counted (LabI n) = n.
Proof.
  eauto.
Qed.

(** incremented equality implies equality *)
Lemma labeq_incr:
forall n1 n2,
LabI (1 + n1) = LabI (1 + n2)
-> LabI n1  = LabI n2.

Proof.
  intros; general induction n1; eauto.
Qed.

Definition lt (l l':lab) :=
  match l, l' with
    LabI n, LabI m => lt n m
  end.

(** ** [lab] *)
Instance lab_StrictOrder : StrictOrder lt (@eq lab).
econstructor. hnf; intros. destruct x,y,z; simpl in *. omega.
intros. destruct x,y; simpl in *. assert (n <> n0) by omega.
hnf; intros. inv H1. congruence.
Qed.

Fixpoint lab_compare (l l' : lab) :=
  match l, l' with
    | LabI n, LabI m => nat_compare n m
  end.

Program Instance lab_OrderedType : UsualOrderedType lab := {
  SOT_lt := lt;
  SOT_cmp := lab_compare;
  SOT_StrictOrder := lab_StrictOrder
}.
Next Obligation.
  case_eq (lab_compare x y); destruct x,y; simpl; intro Hcomp; constructor.
  eapply nat_compare_eq in Hcomp; eauto.
  apply nat_compare_lt in Hcomp; assumption.
  apply nat_compare_gt in Hcomp; assumption.
Qed.

Instance proper_var (ϱ:var -> var)
: Proper (_eq ==> _eq) ϱ.
Proof.
  intuition.
Qed.

Hint Extern 20 (@Proper
               (@respectful _ _
                            (@_eq _ (@SOT_as_OT _ (@eq nat) nat_OrderedType))
                            (@_eq _ (@SOT_as_OT _ (@eq nat) nat_OrderedType))) ?ϱ) => eapply proper_var.

Instance comparison_dec (x y: comparison) : Computable (x = y).
Proof.
  destruct x,y; dec_solve.
Qed.

Instance pos_lt_computable x y : Computable ((x < y)%positive).
Proof.
  unfold Pos.lt. eauto with typeclass_instances.
Qed.

Instance pos_le_computable x y : Computable ((x <= y)%positive).
Proof.
  unfold Pos.le. eauto with typeclass_instances.
Qed.

Instance pos_ge_computable x y : Computable ((x >= y)%positive).
Proof.
    unfold Pos.le. eauto with typeclass_instances.
Qed.

Instance pos_gt_computable x y : Computable ((x > y)%positive).
Proof.
    unfold Pos.le. eauto with typeclass_instances.
Qed.


(* (c) Copyright Microsoft Corporation and Inria.                       *)
(* You may distribute this file under the terms of the CeCILL-B license *)
Require Import ssreflect ssrfun ssrbool.

(******************************************************************************)
(* This file defines two "base" combinatorial interfaces:                     *)
(*    eqType == the structure for types with a decidable equality.            *)
(*              Equality mixins can be made Canonical to allow generic        *)
(*              folding of equality predicates.                               *)
(* subType p == the structure for types isomorphic to {x : T | p x} with      *)
(*              p : pred T for some type T.                                   *)
(* The eqType interface supports the following operations:                    *)
(*          x == y <=> x compares equal to y (this is a boolean test).        *)
(*     x == y :> T <=> x == y at type T.                                      *)
(*          x != y <=> x and y compare unequal.                               *)
(*     x != y :> T <=>  "    "      "    "     at type T.                     *)
(*         x =P y  :: a proof of reflect (x = y) (x == y); this coerces       *)
(*                     to x == y -> x = y.                                    *)
(*    comparable T <-> equality on T is decidable                             *)
(*                    := forall x y : T, decidable (x = y)                    *)
(*  comparableClass compT == eqType mixin/class for compT : comparable T.     *)
(*             pred1 a == the singleton predicate [pred x | x == a].          *)
(* pred2, pred3, pred4 == pair, triple, quad predicates.                      *)
(*            predC1 a == [pred x | x != a].                                  *)
(*      [predU1 a & A] == [pred x | (x == a) || (x \in A)].                   *)
(*      [predD1 A & a] == [pred x | x != a & x \in A].                        *)
(*  predU1 a P, predD1 P a == applicative versions of the above.              *)
(*              frel f == the relation associated with f : T -> T.            *)
(*                     := [rel x y | f x == y].                               *)
(*       invariant k f == elements of T whose k-class is f-invariant.         *)
(*                     := [pred x | k (f x) == k x] with f : T -> T.          *)
(*  [fun x : T => e0 with a1 |-> e1, .., a_n |-> e_n]                         *)
(*  [eta f with a1 |-> e1, .., a_n |-> e_n] ==                                *)
(*    the auto-expanding function that maps x = a_i to e_i, and other values  *)
(*    of x to e0 (resp. f x). In the first form the `: T' is optional and x   *)
(*    can occur in a_i or e_i.                                                *)
(* Equality on an eqType is proof-irrelevant (lemma eq_irrelevance).          *)
(*   The eqType interface is implemented for most standard datatypes:         *)
(*  bool, unit, void, option, prod (denoted A * B), sum (denoted A + B),      *)
(*  sig (denoted {x | P}), sigT (denoted {i : I & T}).                        *)
(*   The fields of sig, sig2, and sigT are renamed sval, svalP, s2val,        *)
(* s2valP, s2valP', tag, and tagged, respectively. We also define             *)
(*   Tagged T_ x == eta-friendly constructor for {i : I | T_ i}, x : T_ i.    *)
(*   tagged_as u v == v cast as T_(tag u) if tag v == tag u, else u.          *)
(*  -> We have u == v <=> (tag u == tag v) && (tagged u == tagged_as u v).    *)
(* The subType interface supports the following operations:                   *)
(*      val == the generic injection from a subType S of T into T.            *)
(*             For example, if u : {x : T | P}, then val u : T.               *)
(*             val is injective because P is proof-irrelevant (P is in bool,  *)
(*             and the is_true coercion expands to P = true).                 *)
(*     valP == the generic proof of P (val u) for u : subType P.              *)
(* Sub x Px == the generic constructor for a subType P; Px is a proof of P x  *)
(*             and P should be inferred from the expected return type.        *)
(*  insub x == the generic partial projection of T into a subType S of T.     *)
(*             This returns an option S; if S : subType P then                *)
(*                insub x = Some u with val u = x if P x,                     *)
(*                          None if ~~ P x                                    *)
(*             The insubP lemma encapsulates this dichotomy.                  *)
(*             P should be infered from the expected return type.             *)
(*  innew x == total (non-option) variant of insub when P = predT.            *)
(* {? x | P} == option {x | P} (syntax for casting insub x).                  *)
(* insubd u0 x == the generic projection with default value u0.               *)
(*             := odflt u0 (insub x).                                         *)
(* insigd A0 x == special case of insubd for S == {x | x \in A}, where A0 is  *)
(*                a proof of x0 \in A.                                        *)
(* insub_eq x == transparent version of insub x that expands to Some/None     *)
(*               when P x can evaluate.                                       *)
(*  The subType P interface is most often implemented using one of:           *)
(*   [subType for S_val]                                                      *)
(*     where S_val : S -> T is the first projection of a type S isomorphic to *)
(*     {x : T | P}.                                                           *)
(*   [newType for S_val]                                                      *)
(*     where S_val : S -> T is the projection of a type S isomorphic to       *)
(*     wrapped T; in this case P must be predT.                               *)
(*   [subType for S_val by Srect], [newType for S_val by Srect]               *)
(*     variants of the above where the eliminator is explicitly provided.     *)
(*     Here S no longer needs to be syntactically identical to {x | P x} or   *)
(*     wrapped T, but it must have a derived constructor S_Sub statisfying an *)
(*     eliminator Srect identical to the one the Coq Inductive command would  *)
(*     have generated, and S_val (S_Sub x Px) (resp. S_val (S_sub x) for the  *)
(*     newType form) must be convertible to x.                                *)
(*     variant of the above when S is a wrapper type for T (so P = predT).    *)
(*   [subType of S], [subType of S for S_val]                                 *)
(*     clones the canonical subType structure for S; if S_val is specified,   *)
(*     then it replaces the inferred projector.                               *)
(* Subtypes inherit the eqType structure of their base types; the generic     *)
(* structure should be explicitly instantiated using the                      *)
(*   [eqMixin of S by <:]                                                     *)
(* construct to declare the Equality mixin; this pattern is repeated for all  *)
(* the combinatorial interfaces (Choice, Countable, Finite).                  *)
(*   More generally, the eqType structure can be transfered by (partial)      *)
(* injections, using:                                                         *)
(*   InjEqMixin injf == an Equality mixin for T, using an f : T -> eT where   *)
(*                      eT has an eqType structure and injf : injective f.    *)
(*    PcanEqMixin fK == an Equality mixin similarly derived from f and a left *)
(*                      inverse partial function g and fK : pcancel f g.      *)
(*     CanEqMixin fK == an Equality mixin similarly derived from f and a left *)
(*                      inverse function g and fK : cancel f g.               *)
(*   We add the following to the standard suffixes documented in ssrbool.v:   *)
(*  1, 2, 3, 4 -- explicit enumeration predicate for 1 (singleton), 2, 3, or  *)
(*                4 values.                                                   *)
(******************************************************************************)

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

Module Equality.

Definition axiom T (e : rel T) := forall x y, reflect (x = y) (e x y).

Structure mixin_of T := Mixin {op : rel T; _ : axiom op}.
Notation class_of := mixin_of (only parsing).

Section ClassDef.

Structure type := Pack {sort; _ : class_of sort; _ : Type}.
Local Coercion sort : type >-> Sortclass.
Variables (T : Type) (cT : type).

Definition class := let: Pack _ c _ := cT return class_of cT in c.

Definition pack c := @Pack T c T.
Definition clone := fun c & cT -> T & phant_id (pack c) cT => pack c.

End ClassDef.

Module Exports.
Coercion sort : type >-> Sortclass.
Notation eqType := type.
Notation EqMixin := Mixin.
Notation EqType T m := (@pack T m).
Notation "[ 'eqMixin' 'of' T ]" := (class _ : mixin_of T)
  (at level 0, format "[ 'eqMixin'  'of'  T ]") : form_scope.
Notation "[ 'eqType' 'of' T 'for' C ]" := (@clone T C _ idfun id)
  (at level 0, format "[ 'eqType'  'of'  T  'for'  C ]") : form_scope.
Notation "[ 'eqType' 'of' T ]" := (@clone T _ _ id id)
  (at level 0, format "[ 'eqType'  'of'  T ]") : form_scope.
End Exports.

End Equality.
Export Equality.Exports.

Definition eq_op T := Equality.op (Equality.class T).

Lemma eqE T x : eq_op x = Equality.op (Equality.class T) x.
Proof. by []. Qed.

Lemma eqP T : Equality.axiom (@eq_op T).
Proof. by case: T => ? []. Qed.
Implicit Arguments eqP [T x y].

Delimit Scope eq_scope with EQ.
Open Scope eq_scope.

Notation "x == y" := (eq_op x y)
  (at level 70, no associativity) : bool_scope.
Notation "x == y :> T" := ((x : T) == (y : T))
  (at level 70, y at next level) : bool_scope.
Notation "x != y" := (~~ (x == y))
  (at level 70, no associativity) : bool_scope.
Notation "x != y :> T" := (~~ (x == y :> T))
  (at level 70, y at next level) : bool_scope.
Notation "x =P y" := (eqP : reflect (x = y) (x == y))
  (at level 70, no associativity) : eq_scope.
Notation "x =P y :> T" := (eqP : reflect (x = y :> T) (x == y :> T))
  (at level 70, y at next level, no associativity) : eq_scope.

Prenex Implicits eq_op eqP.

Lemma eq_refl (T : eqType) (x : T) : x == x. Proof. exact/eqP. Qed.
Notation eqxx := eq_refl.

Lemma eq_sym (T : eqType) (x y : T) : (x == y) = (y == x).
Proof. exact/eqP/eqP. Qed.

Hint Resolve eq_refl eq_sym.

Section Contrapositives.

Variable T : eqType.
Implicit Types (A : pred T) (b : bool) (x : T).

Lemma contraTeq b x y : (x != y -> ~~ b) -> b -> x = y.
Proof. by move=> imp hyp; apply/eqP; apply: contraTT hyp. Qed.

Lemma contraNeq b x y : (x != y -> b) -> ~~ b -> x = y.
Proof. by move=> imp hyp; apply/eqP; apply: contraNT hyp. Qed.

Lemma contraFeq b x y : (x != y -> b) -> b = false -> x = y.
Proof. by move=> imp /negbT; apply: contraNeq. Qed.

Lemma contraTneq b x y : (x = y -> ~~ b) -> b -> x != y.
Proof. by move=> imp; apply: contraTN => /eqP. Qed.

Lemma contraNneq b x y : (x = y -> b) -> ~~ b -> x != y.
Proof. by move=> imp; apply: contraNN => /eqP. Qed.

Lemma contraFneq b x y : (x = y -> b) -> b = false -> x != y.
Proof. by move=> imp /negbT; apply: contraNneq. Qed.

Lemma contra_eqN b x y : (b -> x != y) -> x = y -> ~~ b.
Proof. by move=> imp /eqP; apply: contraL. Qed.

Lemma contra_eqF b x y : (b -> x != y) -> x = y -> b = false.
Proof. by move=> imp /eqP; apply: contraTF. Qed.

Lemma contra_eqT b x y : (~~ b -> x != y) -> x = y -> b.
Proof. by move=> imp /eqP; apply: contraLR. Qed.

Lemma contra_eq x1 y1 x2 y2 : (x2 != y2 -> x1 != y1) -> x1 = y1 -> x2 = y2.
Proof. by move=> imp /eqP; apply: contraTeq. Qed.

Lemma contra_neq x1 y1 x2 y2 : (x2 = y2 -> x1 = y1) -> x1 != y1 -> x2 != y2.
Proof. by move=> imp; apply: contraNneq => /imp->. Qed.

Lemma memPn A x : reflect {in A, forall y, y != x} (x \notin A).
Proof.
apply: (iffP idP) => [notDx y | notDx]; first by apply: contraTneq => ->.
exact: contraL (notDx x) _.
Qed.

Lemma ifN_eq R x y vT vF : x != y -> (if x == y then vT else vF) = vF :> R.
Proof. exact: ifN. Qed.

Lemma ifN_eqC R x y vT vF : x != y -> (if y == x then vT else vF) = vF :> R.
Proof. by rewrite eq_sym; apply: ifN. Qed.

End Contrapositives.

Implicit Arguments memPn [T A x].

Theorem eq_irrelevance (T : eqType) x y : forall e1 e2 : x = y :> T, e1 = e2.
Proof.
pose proj z e := if x =P z is ReflectT e0 then e0 else e.
suff: injective (proj y) by rewrite /proj => injp e e'; apply: injp; case: eqP.
pose join (e : x = _) := etrans (esym e).
apply: can_inj (join x y (proj x (erefl x))) _.
by case: y /; case: _ / (proj x _).
Qed.

Corollary eq_axiomK (T : eqType) (x : T) : all_equal_to (erefl x).
Proof. move=> eq_x_x; exact: eq_irrelevance. Qed.

(* We use the module system to circumvent a silly limitation that  *)
(* forbids using the same constant to coerce to different targets. *)
Module Type EqTypePredSig.
Parameter sort : eqType -> predArgType.
End EqTypePredSig.
Module MakeEqTypePred (eqmod : EqTypePredSig).
Coercion eqmod.sort : eqType >-> predArgType.
End MakeEqTypePred.
Module Export EqTypePred := MakeEqTypePred Equality.

Lemma unit_eqP : Equality.axiom (fun _ _ : unit => true).
Proof. by do 2!case; left. Qed.

Definition unit_eqMixin := EqMixin unit_eqP.
Canonical unit_eqType := Eval hnf in EqType unit unit_eqMixin.

(* Comparison for booleans. *)

(* This is extensionally equal, but not convertible to Bool.eqb. *)
Definition eqb b := addb (~~ b).

Lemma eqbP : Equality.axiom eqb.
Proof. by do 2!case; constructor. Qed.

Canonical bool_eqMixin := EqMixin eqbP.
Canonical bool_eqType := Eval hnf in EqType bool bool_eqMixin.

Lemma eqbE : eqb = eq_op. Proof. by []. Qed.

Lemma bool_irrelevance (x y : bool) (E E' : x = y) : E = E'.
Proof. exact: eq_irrelevance. Qed.

Lemma negb_add b1 b2 : ~~ (b1 (+) b2) = (b1 == b2).
Proof. by rewrite -addNb. Qed.

Lemma negb_eqb b1 b2 : (b1 != b2) = b1 (+) b2.
Proof. by rewrite -addNb negbK. Qed.

Lemma eqb_id b : (b == true) = b.
Proof. by case: b. Qed.

Lemma eqbF_neg b : (b == false) = ~~ b.
Proof. by case: b. Qed.

Lemma eqb_negLR b1 b2 : (~~ b1 == b2) = (b1 == ~~ b2).
Proof. by case: b1; case: b2. Qed.

(* Equality-based predicates.       *)

Notation xpred1 := (fun a1 x => x == a1).
Notation xpred2 := (fun a1 a2 x => (x == a1) || (x == a2)).
Notation xpred3 := (fun a1 a2 a3 x => [|| x == a1, x == a2 | x == a3]).
Notation xpred4 :=
  (fun a1 a2 a3 a4 x => [|| x == a1, x == a2, x == a3 | x == a4]).
Notation xpredU1 := (fun a1 (p : pred _) x => (x == a1) || p x).
Notation xpredC1 := (fun a1 x => x != a1).
Notation xpredD1 := (fun (p : pred _) a1 x => (x != a1) && p x).

Section EqPred.

Variable T : eqType.

Definition pred1 (a1 : T) := SimplPred (xpred1 a1).
Definition pred2 (a1 a2 : T) := SimplPred (xpred2 a1 a2).
Definition pred3 (a1 a2 a3 : T) := SimplPred (xpred3 a1 a2 a3).
Definition pred4 (a1 a2 a3 a4 : T) := SimplPred (xpred4 a1 a2 a3 a4).
Definition predU1 (a1 : T) p := SimplPred (xpredU1 a1 p).
Definition predC1 (a1 : T) := SimplPred (xpredC1 a1).
Definition predD1 p (a1 : T) := SimplPred (xpredD1 p a1).

Lemma pred1E : pred1 =2 eq_op. Proof. move=> x y; exact: eq_sym. Qed.

Variables (T2 : eqType) (x y : T) (z u : T2) (b : bool).

Lemma predU1P : reflect (x = y \/ b) ((x == y) || b).
Proof. apply: (iffP orP) => [] []; by [right | move/eqP; left]. Qed.

Lemma pred2P : reflect (x = y \/ z = u) ((x == y) || (z == u)).
Proof. by apply: (iffP orP) => [] [] /eqP; by [left | right]. Qed.

Lemma predD1P : reflect (x <> y /\ b) ((x != y) && b).
Proof. by apply: (iffP andP)=> [] [] // /eqP. Qed.

Lemma predU1l : x = y -> (x == y) || b.
Proof. by move->; rewrite eqxx. Qed.

Lemma predU1r : b -> (x == y) || b.
Proof. by move->; rewrite orbT. Qed.

Lemma eqVneq : {x = y} + {x != y}.
Proof. by case: eqP; [left | right]. Qed.

End EqPred.

Implicit Arguments predU1P [T x y b].
Implicit Arguments pred2P [T T2 x y z u].
Implicit Arguments predD1P [T x y b].
Prenex Implicits pred1 pred2 pred3 pred4 predU1 predC1 predD1 predU1P.

Notation "[ 'predU1' x & A ]" := (predU1 x [mem A])
  (at level 0, format "[ 'predU1'  x  &  A ]") : fun_scope.
Notation "[ 'predD1' A & x ]" := (predD1 [mem A] x)
  (at level 0, format "[ 'predD1'  A  &  x ]") : fun_scope.

(* Lemmas for reflected equality and functions.   *)

Section EqFun.

Section Exo.

Variables (aT rT : eqType) (D : pred aT) (f : aT -> rT) (g : rT -> aT).

Lemma inj_eq : injective f -> forall x y, (f x == f y) = (x == y).
Proof. by move=> inj_f x y; apply/eqP/eqP=> [|-> //]; exact: inj_f. Qed.

Lemma can_eq : cancel f g -> forall x y, (f x == f y) = (x == y).
Proof. move/can_inj; exact: inj_eq. Qed.

Lemma bij_eq : bijective f -> forall x y, (f x == f y) = (x == y).
Proof. move/bij_inj; apply: inj_eq. Qed.

Lemma can2_eq : cancel f g -> cancel g f -> forall x y, (f x == y) = (x == g y).
Proof. by move=> fK gK x y; rewrite -{1}[y]gK; exact: can_eq. Qed.

Lemma inj_in_eq :
  {in D &, injective f} -> {in D &, forall x y, (f x == f y) = (x == y)}.
Proof. by move=> inj_f x y Dx Dy; apply/eqP/eqP=> [|-> //]; exact: inj_f. Qed.

Lemma can_in_eq :
  {in D, cancel f g} -> {in D &, forall x y, (f x == f y) = (x == y)}.
Proof. by move/can_in_inj; exact: inj_in_eq. Qed.

End Exo.

Section Endo.

Variable T : eqType.

Definition frel f := [rel x y : T | f x == y].

Lemma inv_eq f : involutive f -> forall x y : T, (f x == y) = (x == f y).
Proof. by move=> fK; exact: can2_eq. Qed.

Lemma eq_frel f f' : f =1 f' -> frel f =2 frel f'.
Proof. by move=> eq_f x y; rewrite /= eq_f. Qed.

End Endo.

Variable aT : Type.

(* The invariant of an function f wrt a projection k is the pred of points *)
(* that have the same projection as their image.                           *)

Definition invariant (rT : eqType) f (k : aT -> rT) :=
  [pred x | k (f x) == k x].

Variables (rT1 rT2 : eqType) (f : aT -> aT) (h : rT1 -> rT2) (k : aT -> rT1).

Lemma invariant_comp : subpred (invariant f k) (invariant f (h \o k)).
Proof. by move=> x eq_kfx; rewrite /= (eqP eq_kfx). Qed.

Lemma invariant_inj : injective h -> invariant f (h \o k) =1 invariant f k.
Proof. move=> inj_h x; exact: (inj_eq inj_h). Qed.

End EqFun.

Prenex Implicits frel.

(* The coercion to rel must be explicit for derived Notations to unparse. *)
Notation coerced_frel f := (rel_of_simpl_rel (frel f)) (only parsing).

Section FunWith.

Variables (aT : eqType) (rT : Type).

CoInductive fun_delta : Type := FunDelta of aT & rT.

Definition fwith x y (f : aT -> rT) := [fun z => if z == x then y else f z].

Definition app_fdelta df f z :=
  let: FunDelta x y := df in if z == x then y else f z.

End FunWith.

Prenex Implicits fwith.

Notation "x |-> y" := (FunDelta x y)
  (at level 190, no associativity,
   format "'[hv' x '/ '  |->  y ']'") : fun_delta_scope.

Delimit Scope fun_delta_scope with FUN_DELTA.
Arguments Scope app_fdelta [_ type_scope fun_delta_scope _ _].

Notation "[ 'fun' z : T => F 'with' d1 , .. , dn ]" :=
  (SimplFunDelta (fun z : T =>
     app_fdelta d1%FUN_DELTA .. (app_fdelta dn%FUN_DELTA  (fun _ => F)) ..))
  (at level 0, z ident, only parsing) : fun_scope.

Notation "[ 'fun' z => F 'with' d1 , .. , dn ]" :=
  (SimplFunDelta (fun z =>
     app_fdelta d1%FUN_DELTA .. (app_fdelta dn%FUN_DELTA (fun _ => F)) ..))
  (at level 0, z ident, format
   "'[hv' [ '[' 'fun'  z  => '/ '  F ']' '/'  'with'  '[' d1 , '/'  .. , '/'  dn ']' ] ']'"
   ) : fun_scope.

Notation "[ 'eta' f 'with' d1 , .. , dn ]" :=
  (SimplFunDelta (fun _ =>
     app_fdelta d1%FUN_DELTA .. (app_fdelta dn%FUN_DELTA f) ..))
  (at level 0, z ident, format
  "'[hv' [ '[' 'eta' '/ '  f ']' '/'  'with'  '[' d1 , '/'  .. , '/'  dn ']' ] ']'"
  ) : fun_scope.

(* Various EqType constructions.                                         *)

Section ComparableType.

Variable T : Type.

Definition comparable := forall x y : T, decidable (x = y).

Hypothesis Hcompare : comparable.

Definition compareb x y : bool := Hcompare x y.

Lemma compareP : Equality.axiom compareb.
Proof. by move=> x y; exact: sumboolP. Qed.

Definition comparableClass := EqMixin compareP.

End ComparableType.

Definition eq_comparable (T : eqType) : comparable T :=
  fun x y => decP (x =P y).

Section SubType.

Variables (T : Type) (P : pred T).

Structure subType : Type := SubType {
  sub_sort :> Type;
  val : sub_sort -> T;
  Sub : forall x, P x -> sub_sort;
  _ : forall K (_ : forall x Px, K (@Sub x Px)) u, K u;
  _ : forall x Px, val (@Sub x Px) = x
}.

Implicit Arguments Sub [s].
Lemma vrefl : forall x, P x -> x = x. Proof. by []. Qed.
Definition vrefl_rect := vrefl.

Definition clone_subType U v :=
  fun sT & sub_sort sT -> U =>
  fun c Urec cK (sT' := @SubType U v c Urec cK) & phant_id sT' sT => sT'.

Variable sT : subType.

CoInductive Sub_spec : sT -> Type := SubSpec x Px : Sub_spec (Sub x Px).

Lemma SubP u : Sub_spec u.
Proof. by case: sT Sub_spec SubSpec u => T' _ C rec /= _. Qed.

Lemma SubK x Px : @val sT (Sub x Px) = x.
Proof. by case: sT. Qed.

Definition insub x :=
  if @idP (P x) is ReflectT Px then @Some sT (Sub x Px) else None.

Definition insubd u0 x := odflt u0 (insub x).

CoInductive insub_spec x : option sT -> Type :=
  | InsubSome u of P x & val u = x : insub_spec x (Some u)
  | InsubNone   of ~~ P x          : insub_spec x None.

Lemma insubP x : insub_spec x (insub x).
Proof.
by rewrite /insub; case: {-}_ / idP; [left; rewrite ?SubK | right; exact/negP].
Qed.

Lemma insubT x Px : insub x = Some (Sub x Px).
Proof.
case: insubP; last by case/negP.
case/SubP=> y Py _ def_x; rewrite -def_x SubK in Px *.
congr (Some (Sub _ _)); exact: bool_irrelevance.
Qed.

Lemma insubF x : P x = false -> insub x = None.
Proof. by move/idP; case: insubP. Qed.

Lemma insubN x : ~~ P x -> insub x = None.
Proof. by move/negPf/insubF. Qed.

Lemma isSome_insub : ([eta insub] : pred T) =1 P.
Proof. by apply: fsym => x; case: insubP => // /negPf. Qed.

Lemma insubK : ocancel insub (@val _).
Proof. by move=> x; case: insubP. Qed.

Lemma valP (u : sT) : P (val u).
Proof. by case/SubP: u => x Px; rewrite SubK. Qed.

Lemma valK : pcancel (@val _) insub.
Proof. case/SubP=> x Px; rewrite SubK; exact: insubT. Qed.

Lemma val_inj : injective (@val sT).
Proof. exact: pcan_inj valK. Qed.

Lemma valKd u0 : cancel (@val _) (insubd u0).
Proof. by move=> u; rewrite /insubd valK. Qed.

Lemma val_insubd u0 x : val (insubd u0 x) = if P x then x else val u0.
Proof. by rewrite /insubd; case: insubP => [u -> | /negPf->]. Qed.

Lemma insubdK u0 : {in P, cancel (insubd u0) (@val _)}.
Proof. by move=> x Px; rewrite /= val_insubd [P x]Px. Qed.

Definition insub_eq x :=
  let Some_sub Px := Some (Sub x Px : sT) in
  let None_sub _ := None in
  (if P x as Px return P x = Px -> _ then Some_sub else None_sub) (erefl _).

Lemma insub_eqE : insub_eq =1 insub.
Proof.
rewrite /insub_eq /insub => x; case: {2 3}_ / idP (erefl _) => // Px Px'.
by congr (Some _); apply: val_inj; rewrite !SubK.
Qed.

End SubType.

Implicit Arguments SubType [T P].
Implicit Arguments Sub [T P s].
Implicit Arguments vrefl [T P].
Implicit Arguments vrefl_rect [T P].
Implicit Arguments clone_subType [T P sT c Urec cK].
Implicit Arguments insub [T P sT].
Implicit Arguments insubT [T sT x].
Implicit Arguments val_inj [T P sT].
Prenex Implicits val Sub vrefl vrefl_rect insub insubd val_inj.

Local Notation inlined_sub_rect :=
  (fun K K_S u => let (x, Px) as u return K u := u in K_S x Px).

Local Notation inlined_new_rect :=
  (fun K K_S u => let (x) as u return K u := u in K_S x).

Notation "[ 'subType' 'for' v ]" := (SubType _ v _ inlined_sub_rect vrefl_rect)
 (at level 0, only parsing) : form_scope.

Notation "[ 'sub' 'Type' 'for' v ]" := (SubType _ v _ _ vrefl_rect)
 (at level 0, format "[ 'sub' 'Type'  'for'  v ]") : form_scope.

Notation "[ 'subType' 'for' v 'by' rec ]" := (SubType _ v _ rec vrefl)
 (at level 0, format "[ 'subType'  'for'  v  'by'  rec ]") : form_scope.

Notation "[ 'subType' 'of' U 'for' v ]" := (clone_subType U v id idfun)
 (at level 0, format "[ 'subType'  'of'  U  'for'  v ]") : form_scope.

(*
Notation "[ 'subType' 'for' v ]" := (clone_subType _ v id idfun)
 (at level 0, format "[ 'subType'  'for'  v ]") : form_scope.
*)
Notation "[ 'subType' 'of' U ]" := (clone_subType U _ id id)
 (at level 0, format "[ 'subType'  'of'  U ]") : form_scope.

Definition NewType T U v c Urec :=
  let Urec' P IH := Urec P (fun x : T => IH x isT : P _) in
  SubType U v (fun x _ => c x) Urec'.
Implicit Arguments NewType [T U].

Notation "[ 'newType' 'for' v ]" := (NewType v _ inlined_new_rect vrefl_rect)
 (at level 0, only parsing) : form_scope.

Notation "[ 'new' 'Type' 'for' v ]" := (NewType v _ _ vrefl_rect)
 (at level 0, format "[ 'new' 'Type'  'for'  v ]") : form_scope.

Notation "[ 'newType' 'for' v 'by' rec ]" := (NewType v _ rec vrefl)
 (at level 0, format "[ 'newType'  'for'  v  'by'  rec ]") : form_scope.

Definition innew T nT x := @Sub T predT nT x (erefl true).
Implicit Arguments innew [T nT].
Prenex Implicits innew.

Lemma innew_val T nT : cancel val (@innew T nT).
Proof. by move=> u; apply: val_inj; exact: SubK. Qed.

(* Prenex Implicits and renaming. *)
Notation sval := (@proj1_sig _ _).
Notation "@ 'sval'" := (@proj1_sig) (at level 10, format "@ 'sval'").

Section SigProj.

Variables (T : Type) (P Q : T -> Prop).

Lemma svalP : forall u : sig P, P (sval u). Proof. by case. Qed.

Definition s2val (u : sig2 P Q) := let: exist2 x _ _ := u in x.

Lemma s2valP u : P (s2val u). Proof. by case: u. Qed.

Lemma s2valP' u : Q (s2val u). Proof. by case: u. Qed.

End SigProj.

Prenex Implicits svalP s2val s2valP s2valP'.

Canonical sig_subType T (P : pred T) : subType [eta P] :=
  Eval hnf in [subType for @sval T [eta [eta P]]].

(* Shorthand for sigma types over collective predicates. *)
Notation "{ x 'in' A }" := {x | x \in A}
  (at level 0, x at level 99, format  "{ x  'in'  A }") : type_scope.
Notation "{ x 'in' A | P }" := {x | (x \in A) && P}
  (at level 0, x at level 99, format  "{ x  'in'  A  |  P }") : type_scope.

(* Shorthand for the return type of insub. *)
Notation "{ ? x : T | P }" := (option {x : T | is_true P})
  (at level 0, x at level 99, only parsing) : type_scope.
Notation "{ ? x | P }" := {? x : _ | P}
  (at level 0, x at level 99, format  "{ ?  x  |  P }") : type_scope.
Notation "{ ? x 'in' A }" := {? x | x \in A}
  (at level 0, x at level 99, format  "{ ?  x  'in'  A }") : type_scope.
Notation "{ ? x 'in' A | P }" := {? x | (x \in A) && P}
  (at level 0, x at level 99, format  "{ ?  x  'in'  A  |  P }") : type_scope.

(* A variant of injection with default that infers a collective predicate *)
(* from the membership proof for the default value.                       *)
Definition insigd T (A : mem_pred T) x (Ax : in_mem x A) :=
  insubd (exist [eta A] x Ax).

(* There should be a rel definition for the subType equality op, but this *)
(* seems to cause the simpl tactic to diverge on expressions involving == *)
(* on 4+ nested subTypes in a "strict" position (e.g., after ~~).         *)
(* Definition feq f := [rel x y | f x == f y].                            *)

Section TransferEqType.

Variables (T : Type) (eT : eqType) (f : T -> eT).

Lemma inj_eqAxiom : injective f -> Equality.axiom (fun x y => f x == f y).
Proof. by move=> f_inj x y; apply: (iffP eqP) => [|-> //]; exact: f_inj. Qed.

Definition InjEqMixin f_inj := EqMixin (inj_eqAxiom f_inj).

Definition PcanEqMixin g (fK : pcancel f g) := InjEqMixin (pcan_inj fK).

Definition CanEqMixin g (fK : cancel f g) := InjEqMixin (can_inj fK).

End TransferEqType.

Section SubEqType.

Variables (T : eqType) (P : pred T) (sT : subType P).

Notation Local ev_ax := (fun T v => @Equality.axiom T (fun x y => v x == v y)).
Lemma val_eqP : ev_ax sT val. Proof. exact: inj_eqAxiom val_inj. Qed.

Definition sub_eqMixin := EqMixin val_eqP.
Canonical sub_eqType := Eval hnf in EqType sT sub_eqMixin.

Definition SubEqMixin :=
  (let: SubType _ v _ _ _ as sT' := sT
     return ev_ax sT' val -> Equality.class_of sT' in
   fun vP : ev_ax _ v => EqMixin vP
   ) val_eqP.

Lemma val_eqE (u v : sT) : (val u == val v) = (u == v).
Proof. by []. Qed.

End SubEqType.

Implicit Arguments val_eqP [T P sT x y].
Prenex Implicits val_eqP.

Notation "[ 'eqMixin' 'of' T 'by' <: ]" := (SubEqMixin _ : Equality.class_of T)
  (at level 0, format "[ 'eqMixin'  'of'  T  'by'  <: ]") : form_scope.

Section SigEqType.

Variables (T : eqType) (P : pred T).

Definition sig_eqMixin := Eval hnf in [eqMixin of {x | P x} by <:].
Canonical sig_eqType := Eval hnf in EqType {x | P x} sig_eqMixin.

End SigEqType.

Section ProdEqType.

Variable T1 T2 : eqType.

Definition pair_eq := [rel u v : T1 * T2 | (u.1 == v.1) && (u.2 == v.2)].

Lemma pair_eqP : Equality.axiom pair_eq.
Proof.
move=> [x1 x2] [y1 y2] /=; apply: (iffP andP) => [[]|[<- <-]] //=.
by do 2!move/eqP->.
Qed.

Definition prod_eqMixin := EqMixin pair_eqP.
Canonical prod_eqType := Eval hnf in EqType (T1 * T2) prod_eqMixin.

Lemma pair_eqE : pair_eq = eq_op :> rel _. Proof. by []. Qed.

Lemma xpair_eqE (x1 y1 : T1) (x2 y2 : T2) :
  ((x1, x2) == (y1, y2)) = ((x1 == y1) && (x2 == y2)).
Proof. by []. Qed.

Lemma pair_eq1 (u v : T1 * T2) : u == v -> u.1 == v.1.
Proof. by case/andP. Qed.

Lemma pair_eq2 (u v : T1 * T2) : u == v -> u.2 == v.2.
Proof. by case/andP. Qed.

End ProdEqType.

Implicit Arguments pair_eqP [T1 T2].

Prenex Implicits pair_eqP.

Definition predX T1 T2 (p1 : pred T1) (p2 : pred T2) :=
  [pred z | p1 z.1 & p2 z.2].

Notation "[ 'predX' A1 & A2 ]" := (predX [mem A1] [mem A2])
  (at level 0, format "[ 'predX'  A1  &  A2 ]") : fun_scope.

Section OptionEqType.

Variable T : eqType.

Definition opt_eq (u v : option T) : bool :=
  oapp (fun x => oapp (eq_op x) false v) (~~ v) u.

Lemma opt_eqP : Equality.axiom opt_eq.
Proof.
case=> [x|] [y|] /=; by [constructor | apply: (iffP eqP) => [|[]] ->].
Qed.

Canonical option_eqMixin := EqMixin opt_eqP.
Canonical option_eqType := Eval hnf in EqType (option T) option_eqMixin.

End OptionEqType.

Definition tag := projS1.
Definition tagged I T_ :  forall u, T_(tag u) := @projS2 I [eta T_].
Definition Tagged I i T_ x := @existS I [eta T_] i x.
Implicit Arguments Tagged [I i].
Prenex Implicits tag tagged Tagged.

Section TaggedAs.

Variables (I : eqType) (T_ : I -> Type).
Implicit Types u v : {i : I & T_ i}.

Definition tagged_as u v :=
  if tag u =P tag v is ReflectT eq_uv then
    eq_rect_r T_ (tagged v) eq_uv
  else tagged u.

Lemma tagged_asE u x : tagged_as u (Tagged T_ x) = x.
Proof.
by rewrite /tagged_as /=; case: eqP => // eq_uu; rewrite [eq_uu]eq_axiomK.
Qed.

End TaggedAs.

Section TagEqType.

Variables (I : eqType) (T_ : I -> eqType).
Implicit Types u v : {i : I & T_ i}.

Definition tag_eq u v := (tag u == tag v) && (tagged u == tagged_as u v).

Lemma tag_eqP : Equality.axiom tag_eq.
Proof.
rewrite /tag_eq => [] [i x] [j] /=.
case: eqP => [<-|Hij] y; last by right; case.
by apply: (iffP eqP) => [->|<-]; rewrite tagged_asE.
Qed.

Canonical tag_eqMixin := EqMixin tag_eqP.
Canonical tag_eqType := Eval hnf in EqType {i : I & T_ i} tag_eqMixin.

Lemma tag_eqE : tag_eq = eq_op. Proof. by []. Qed.

Lemma eq_tag u v : u == v -> tag u = tag v.
Proof. by move/eqP->. Qed.

Lemma eq_Tagged u x :(u == Tagged _ x) = (tagged u == x).
Proof. by rewrite -tag_eqE /tag_eq eqxx tagged_asE. Qed.

End TagEqType.

Implicit Arguments tag_eqP [I T_ x y].
Prenex Implicits tag_eqP.

Section SumEqType.

Variables T1 T2 : eqType.
Implicit Types u v : T1 + T2.

Definition sum_eq u v :=
  match u, v with
  | inl x, inl y | inr x, inr y => x == y
  | _, _ => false
  end.

Lemma sum_eqP : Equality.axiom sum_eq.
Proof. case=> x [] y /=; by [right | apply: (iffP eqP) => [->|[->]]]. Qed.

Canonical sum_eqMixin := EqMixin sum_eqP.
Canonical sum_eqType := Eval hnf in EqType (T1 + T2) sum_eqMixin.

Lemma sum_eqE : sum_eq = eq_op. Proof. by []. Qed.

End SumEqType.

Implicit Arguments sum_eqP [T1 T2 x y].
Prenex Implicits sum_eqP.


From Coq.ssr Require Import ssreflect.
From stdpp Require Import gmap.
From aneris.prelude Require Import gset_map.

Section sig_gset.
  Context `{EqDecision A, !Countable A}.

  (* TODO: upstream? *)
  Lemma length_elements (X : gset A) : length (elements X) = size X.
  Proof.
    induction X using set_ind_L.
    - rewrite elements_empty size_empty //.
    - rewrite size_union ?size_singleton; [set_solver|].
      rewrite elements_union_singleton //.
  Qed.

  Definition sig_gset (X : gset A) : Type := { a : A | a ∈ X }.

  Program Fixpoint sig_gset_list (X : gset A) (l : list A)
          (Hl : ∀ a, a ∈ l → a ∈ X) : list (sig_gset X) :=
    match l as l' return (∀ a, a ∈ l' → a ∈ X) → list { a : A | a ∈ X } with
    | [] => λ _, []
    | a :: l' => λ H, (a ↾ (H a _)) :: sig_gset_list X l' (λ b Hb, H b _)
    end Hl.
  Next Obligation. constructor. Qed.
  Next Obligation. by constructor. Qed.

  Lemma elem_of_sig_gset_list_lookup X l i (x : sig_gset X) H :
    sig_gset_list X l H !! i = Some x ↔ l !! i = Some (`x).
  Proof.
    revert i; induction l; [done|]. split.
    - destruct i; [by intros [= <-]|]. apply IHl.
    - destruct i; [|by apply IHl].
      intros [= ->]=> /=. f_equal.
      destruct x; simpl. f_equal. apply proof_irrel.
  Qed.

  Lemma length_sig_gset_list X l H :
    length (sig_gset_list X l H) = length l.
  Proof. induction l; naive_solver. Qed.

  Lemma sig_gset_list_proof_irrel X l H1 H2 :
    sig_gset_list X l H1 = sig_gset_list X l H2.
  Proof.
    induction l as [|?? IH]; [done|].
    simpl. f_equal; [|apply IH].
    f_equal. apply proof_irrel.
  Qed.

  Lemma sig_gset_list_cons X a l H :
    ∃ Ha Hl, sig_gset_list X (a :: l) H = a ↾ Ha :: sig_gset_list X l Hl.
  Proof.
    assert (∀ a, a ∈ l → a ∈ X) as Hl by set_solver.
    exists (H a (elem_of_list_here _ _)), Hl.
    simpl. f_equal; [| apply sig_gset_list_proof_irrel].
    f_equal. apply proof_irrel.
  Qed.

  Lemma sig_gset_list_singleton_list a X H :
    ∃ Ha, sig_gset_list X [a] H = [a ↾ Ha].
  Proof.
    exists (H a (elem_of_list_here _ _)).
    simpl. do 2 f_equal. apply proof_irrel.
  Qed.

  Lemma sig_gset_list_singleton_set a l H :
    l = [a] → ∃ Ha, sig_gset_list {[a]} l H = [a ↾ Ha].
  Proof. intros ->. eexists (H a _). simpl. do 2 f_equal. Qed.

  Program Definition sig_gset_gset (X : gset A) : gset (sig_gset X) :=
    list_to_set (C := gset _) (sig_gset_list X (elements X) _).
  Next Obligation. intros ??. by apply elem_of_elements. Qed.

  Lemma elem_of_sig_gset_gset X a :
    a ∈ sig_gset_gset X ↔ `a ∈ X.
  Proof.
    destruct a. split; [done|].
    intros [i ?]%elem_of_elements%elem_of_list_lookup_1.
    rewrite /sig_gset_gset elem_of_list_to_set.
    apply (elem_of_list_lookup_2 _ i).
    by apply elem_of_sig_gset_list_lookup.
  Qed.

  Lemma sig_gset_gset_singleton a :
    ∃ Ha, sig_gset_gset {[a]} = {[a ↾ Ha]}.
  Proof.
    assert (a ∈ ({[a]} : gset _)) as Ha by set_solver.
    eexists Ha. apply set_eq. intros ?.
    rewrite elem_of_sig_gset_gset //.
  Qed.

  Lemma sig_gset_gset_empty :
    sig_gset_gset ∅ = ∅.
  Proof. done. Qed.

  Lemma size_sig_gset X :
    size X = size (sig_gset_gset X).
  Proof.
    rewrite /sig_gset_gset -length_elements.
    refine ((fix IH l H (Hnodup : NoDup l) :=
               match l as l' return
                     l = l' →
                     NoDup l' →
                     ∀ (H : ∀ x, x ∈ l' → x ∈ _),
                       length l' =
                       size (list_to_set (sig_gset_list X l' H)) with
               | [] => _
               | a :: l' => _
               end eq_refl Hnodup H) (elements X) _ _).
    - intros -> ??. rewrite size_empty //.
    - intros -> Hd ?. inversion Hd; simplify_eq.
      edestruct sig_gset_list_cons as [? [? ->]].
      simpl. rewrite size_union ?size_singleton ?IH //.
      rewrite disjoint_singleton_l.
      rewrite elem_of_list_to_set.
      intros [? Hl']%elem_of_list_lookup_1.
      by apply elem_of_sig_gset_list_lookup, elem_of_list_lookup_2 in Hl'.
    - apply NoDup_elements.
  Qed.

  Lemma sig_gset_map_proj1_sig_subseteq (X : gset A) (Y : gset (sig_gset X)) :
    gset_map proj1_sig Y ⊆ X.
  Proof. set_unfold. by intros ? ([] & -> &?). Qed.

End sig_gset.

#[global] Hint Extern 1 ((`?p) ∈ _) => apply (proj2_sig p) : core.
#[global] Hint Extern 1 (_ ∈ sig_gset_gset _) => apply elem_of_sig_gset_gset : core.


(* Contribution to the Coq Library   V6.3 (July 1999)                    *)

Inductive color : Set :=
  | blue : color
  | red : color
  | yellow : color.

Inductive tree1 : Set :=
  | Leaf : nat -> tree1
  | Nd1 : color -> tree1 -> tree1.

Fixpoint def_cop (T : tree1) : tree1 :=
  match T with
  | Leaf n => Leaf n
  | Nd1 blue t => Nd1 red (def_cop t)
  | Nd1 red t => Nd1 red (def_cop t)
  | Nd1 yellow t => Nd1 yellow (def_cop t)
  end.

Require Import Mx_defs.
Require Extraction.

(* (Mx P A) computes an inhabitant of A but may raise an exception if P *)
Theorem core_cop :
 forall t : tree1,
 Mx (t = def_cop t) {t' : tree1 | t' = def_cop t &  t <> t'}.

fix 1.
intro t; case t; clear t.
  simpl in |- *; intros n. apply Mx_raise. trivial.

  intros c t1; case c; simpl in |- *; clear c.
    (* c = blue *)
    apply Mx_unit.                   (* cheating *)
    apply Mx_try with (1 := core_cop t1).
      intros (t', eg, di); exists (Nd1 red t');
       [ elim eg; trivial | simplify_eq ].
      intro eg; exists (Nd1 red t1); [ elim eg; trivial | simplify_eq ].

     (* c = red *)
    apply Mx_bind with (1 := core_cop t1).
      intros (t', eg, di); apply Mx_unit. exists (Nd1 red t'); [ elim eg; trivial | simplify_eq; assumption ].
      intro eg; simpl in |- *; elim eg; trivial.

    (* c = yellow *)
    apply Mx_bind with (1 := core_cop t1).
      intros (t', eg, di); apply Mx_unit. exists (Nd1 yellow t'); [ elim eg; trivial | simplify_eq; assumption ].
      intro eg; simpl in |- *; elim eg; trivial.
Defined.

Theorem eff_cop : forall t : tree1, {t' : tree1 | t' = def_cop t}.
intro t; apply Mx_try with (1 := core_cop t).
    intros (x, e, n); exists x; auto.
    intro eg; exists t; trivial.
Defined.

(* Extracting terms typed in system F but not in ML *)
(* In the extracted ML program, you have to
    - put an Obj.magic in front of each call to mx_try
      (at least for each recursive (then polymorphic) use of mx_try)
*)

Extraction
 "copy_cheat_extr.ml" Mx_unit Mx_raise Mx_try Mx_bind core_cop eff_cop.


Require Export SpecSyntax.

Reserved Notation "⟨ x : τ ∈ Γ ⟩"
  ( at level 0,
    x at level 98,
    τ at level 98,
    Γ at level 98).

Inductive GetTmVar : Env → Ix → Exp → Prop :=
  | tm_here {Γ τ} :
      ⟨   O : τ[wkm] ∈ Γ ▻ τ ⟩
  | tm_there_evar {Γ x τ τ'} :
      ⟨   x : τ      ∈ Γ      ⟩ →
      ⟨ S x : τ[wkm] ∈ Γ ▻ τ' ⟩
  | tm_there_τvar {Γ x τ k'} :
      ⟨   x : τ      ∈ Γ      ⟩ →
      ⟨ S x : τ[wkm] ∈ Γ ► k' ⟩
  | tm_there_γvar {Γ x τ τ1' τ2' k'} :
      ⟨   x : τ      ∈ Γ      ⟩ →
      ⟨ S x : τ[wkm] ∈ Γ ◅ τ1' ~ τ2' ∷ k' ⟩
where "⟨ x : τ ∈ Γ ⟩" := (GetTmVar Γ x τ).

Reserved Notation "⟨ α ∷ k ∈ Γ ⟩"
  ( at level 0,
    α at level 98,
    k at level 98,
    Γ at level 98).

Inductive GetTyVar : Env → Ix → Kind → Prop :=
  | ty_here {Γ k} :
      ⟨   O ∷ k ∈ Γ ► k ⟩
  | ty_there_evar {Γ α k τ'} :
      ⟨   α ∷ k ∈ Γ      ⟩ →
      ⟨ S α ∷ k ∈ Γ ▻ τ' ⟩
  | ty_there_τvar {Γ α k k'} :
      ⟨   α ∷ k ∈ Γ      ⟩ →
      ⟨ S α ∷ k ∈ Γ ► k' ⟩
  | ty_there_γvar {Γ α k τ1' τ2' k'} :
      ⟨   α ∷ k ∈ Γ      ⟩ →
      ⟨ S α ∷ k ∈ Γ ◅ τ1' ~ τ2' ∷ k' ⟩
where "⟨ α ∷ k ∈ Γ ⟩" := (GetTyVar Γ α k).

Reserved Notation "⟨ c : τ1 ~ τ2 ∷ k ∈ Γ ⟩"
  ( at level 0,
    c at level 98,
    τ1 at level 98,
    τ2 at level 98,
    k at level 98,
    Γ at level 98).

Inductive GetCoVar : Env → Ix → Exp → Exp → Kind → Prop :=
  | co_here {Γ τ1 τ2 k} :
      ⟨   O : τ1[wkm] ~ τ2[wkm] ∷ k ∈ Γ ◅ τ1 ~ τ2 ∷ k ⟩
  | co_there_evar {Γ c τ1 τ2 k τ'} :
      ⟨   c : τ1      ~ τ2      ∷ k ∈ Γ      ⟩ →
      ⟨ S c : τ1[wkm] ~ τ2[wkm] ∷ k ∈ Γ ▻ τ' ⟩
  | co_there_τvar {Γ c τ1 τ2 k k'} :
      ⟨   c : τ1      ~ τ2      ∷ k ∈ Γ      ⟩ →
      ⟨ S c : τ1[wkm] ~ τ2[wkm] ∷ k ∈ Γ ► k' ⟩
  | co_there_γvar {Γ c τ1 τ2 k τ1' τ2' k'} :
      ⟨   c : τ1      ~ τ2      ∷ k ∈ Γ      ⟩ →
      ⟨ S c : τ1[wkm] ~ τ2[wkm] ∷ k ∈ Γ ◅ τ1' ~ τ2' ∷ k' ⟩
where "⟨ c : τ1 ~ τ2 ∷ k ∈ Γ ⟩" := (GetCoVar Γ c τ1 τ2 k).

Reserved Notation "⟨ Γ ⊢ τ ∷ k ⟩"
  ( at level 0,
    Γ at level 98,
    τ at level 98,
    k at level 98).

Inductive Ty (Γ: Env) : Exp → Kind → Prop :=
  | TyVar {α k} :
      ⟨ α ∷ k ∈ Γ ⟩ →
      ⟨ Γ ⊢ var α ∷ k ⟩
  | TAbs {τ k1 k2} :
      ⟨ Γ ► k1 ⊢ τ ∷ k2 ⟩ →
      ⟨ Γ ⊢ τabs k1 τ ∷ karr k1 k2 ⟩
  | TApp {τ1 τ2 k1 k2}:
      ⟨ Γ ⊢ τ1 ∷ karr k1 k2 ⟩ →
      ⟨ Γ ⊢ τ2 ∷ k1 ⟩ →
      ⟨ Γ ⊢ τapp τ1 τ2 ∷ k2 ⟩
  | Arr {τ1 τ2} :
      ⟨ Γ ⊢ τ1 ∷ kstar ⟩ →
      ⟨ Γ ⊢ τ2 ∷ kstar ⟩ →
      ⟨ Γ ⊢ arr τ1 τ2 ∷ kstar ⟩
  | Arrτ {τ k} :
      ⟨ Γ ► k ⊢ τ ∷ kstar ⟩ →
      ⟨ Γ ⊢ arrτ k τ ∷ kstar ⟩
  | Arrγ {τ1 τ2 τ3 k} :
      ⟨ Γ ⊢ τ1 ∷ k ⟩ →
      ⟨ Γ ⊢ τ2 ∷ k ⟩ →
      ⟨ Γ ⊢ τ3 ∷ kstar ⟩ →
      ⟨ Γ ⊢ arrγ τ1 τ2 k τ3 ∷ kstar ⟩
where "⟨ Γ ⊢ τ ∷ k ⟩" := (Ty Γ τ k).

Reserved Notation "⟨ Γ ⊢ γ : τ1 ~ τ2 ∷ k ⟩"
  ( at level 0,
    Γ at level 98,
    γ at level 98,
    τ1 at level 98,
    τ2 at level 98,
    k at level 98).

Inductive Co (Γ: Env) : Exp → Exp → Exp → Kind → Prop :=
  | CoVar {c τ1 τ2 k} :
      ⟨ c : τ1 ~ τ2 ∷ k ∈ Γ ⟩ →
      ⟨ Γ ⊢ var c : τ1 ~ τ2 ∷ k ⟩
  | CoTAbs {γ τ1 τ2 k1 k2} :
      ⟨ Γ ► k1 ⊢ γ : τ1 ~ τ2 ∷ k2 ⟩ →
      ⟨ Γ ⊢ coτabs k1 γ : τabs k1 τ1 ~ τabs k1 τ2 ∷ karr k1 k2 ⟩
  | CoTApp {γ1 γ2 τ11 τ12 τ21 τ22 k1 k2 }:
      ⟨ Γ ⊢ γ1 : τ11 ~ τ21 ∷ karr k1 k2 ⟩ →
      ⟨ Γ ⊢ γ2 : τ12 ~ τ22 ∷ k1 ⟩ →
      ⟨ Γ ⊢ coτapp γ1 γ2 : τapp τ11 τ12 ~ τapp τ21 τ22 ∷ k2 ⟩
  | CoArr {γ1 γ2 τ11 τ12 τ21 τ22}:
      ⟨ Γ ⊢ γ1 : τ11 ~ τ21 ∷ kstar ⟩ →
      ⟨ Γ ⊢ γ2 : τ12 ~ τ22 ∷ kstar ⟩ →
      ⟨ Γ ⊢ coarr γ1 γ2 : arr τ11 τ12 ~ arr τ21 τ22 ∷ kstar ⟩
  | CoArrτ {γ τ1 τ2 k} :
      ⟨ Γ ► k ⊢ γ : τ1 ~ τ2 ∷ kstar ⟩ →
      ⟨ Γ ⊢ coarrτ k γ : arrτ k τ1 ~ arrτ k τ2 ∷ kstar ⟩
  | CoArrγ {γ1 γ2 γ3 τ1 τ1' τ2 τ2' τ3 τ3' k} :
      ⟨ Γ ⊢ γ1 : τ1 ~ τ1' ∷ k ⟩ →
      ⟨ Γ ⊢ γ2 : τ2 ~ τ2' ∷ k ⟩ →
      ⟨ Γ ⊢ γ3 : τ3 ~ τ3' ∷ kstar ⟩ →
      ⟨ Γ ⊢ coarrγ γ1 γ2 k γ3 : arrγ τ1 τ2 k τ3 ~ arrγ τ1' τ2' k τ3' ∷ kstar ⟩
  | CoInvArr₁ {γ τ1 τ2 τ3 τ4}:
      ⟨ Γ ⊢ γ : arr τ1 τ2 ~ arr τ3 τ4 ∷ kstar ⟩ →
      ⟨ Γ ⊢ coinvarr₁ γ : τ1 ~ τ3 ∷ kstar ⟩
  | CoInvArr₂ {γ τ1 τ2 τ3 τ4}:
      ⟨ Γ ⊢ γ : arr τ1 τ2 ~ arr τ3 τ4 ∷ kstar ⟩ →
      ⟨ Γ ⊢ coinvarr₂ γ : τ2 ~ τ4 ∷ kstar ⟩
  | CoInvArrτ {γ1 γ2 τ1 τ2 τ3 τ4 k} :
      ⟨ Γ ⊢ γ1 : arrτ k τ1 ~ arrτ k τ2 ∷ kstar ⟩ →
      ⟨ Γ ⊢ γ2 : τ3 ~ τ4 ∷ k ⟩ →
      ⟨ Γ ⊢ coinvarrτ γ1 γ2 : τ1[beta1 τ3] ~ τ2[beta1 τ4] ∷ kstar ⟩
  | CoInvArrγ₁ {γ τ1 τ1' τ2 τ2' τ3 τ3' k} :
      ⟨ Γ ⊢ γ : arrγ τ1 τ2 k τ3 ~ arrγ τ1' τ2' k τ3' ∷ kstar ⟩ →
      ⟨ Γ ⊢ coinvarrγ₁ γ : τ1 ~ τ1' ∷ k ⟩
  | CoInvArrγ₂ {γ τ1 τ1' τ2 τ2' τ3 τ3' k} :
      ⟨ Γ ⊢ γ : arrγ τ1 τ2 k τ3 ~ arrγ τ1' τ2' k τ3' ∷ kstar ⟩ →
      ⟨ Γ ⊢ coinvarrγ₂ γ : τ2 ~ τ2' ∷ k ⟩
  | CoInvArrγ₃ {γ τ1 τ1' τ2 τ2' τ3 τ3' k} :
      ⟨ Γ ⊢ γ : arrγ τ1 τ2 k τ3 ~ arrγ τ1' τ2' k τ3' ∷ kstar ⟩ →
      ⟨ Γ ⊢ coinvarrγ₃ γ : τ3 ~ τ3' ∷ kstar ⟩
  | CoBeta {γ1 γ2 τ1 τ2 τ1' τ2' k1 k2} :
      ⟨ Γ ► k1 ⊢ γ1 : τ1 ~ τ1' ∷ k2 ⟩ →
      ⟨ Γ ⊢ γ2 : τ2 ~ τ2' ∷ k1 ⟩ →
      ⟨ Γ ⊢ cobeta k1 γ1 γ2 : τapp (τabs k1 τ1) τ2 ~ τ1'[beta1 τ2'] ∷ k2 ⟩
  | CoRefl {τ k} :
      ⟨ Γ ⊢ τ ∷ k ⟩ →
      ⟨ Γ ⊢ corefl τ : τ ~ τ ∷ k ⟩
  | CoSym {γ τ1 τ2 k} :
      ⟨ Γ ⊢ γ : τ1 ~ τ2 ∷ k ⟩ →
      ⟨ Γ ⊢ cosym γ : τ2 ~ τ1 ∷ k ⟩
  | CoTrans {γ1 γ2 τ1 τ2 τ3 k} :
      ⟨ Γ ⊢ γ1 : τ1 ~ τ2 ∷ k ⟩ →
      ⟨ Γ ⊢ γ2 : τ2 ~ τ3 ∷ k ⟩ →
      ⟨ Γ ⊢ cotrans γ1 γ2 : τ1 ~ τ3 ∷ k ⟩
where "⟨ Γ ⊢ γ : τ1 ~ τ2 ∷ k ⟩" := (Co Γ γ τ1 τ2 k).

Reserved Notation "⟨ Γ ⊢ γ : τ1 ↝ τ2 ∷ k ⟩"
  ( at level 0,
    Γ at level 98,
    γ at level 98,
    τ1 at level 98,
    τ2 at level 98,
    k at level 98).

Inductive Red (Γ: Env) : Exp → Exp → Exp → Kind → Prop :=
  | RedVar {c τ1 τ2 k} :
      ⟨ c : τ1 ~ τ2 ∷ k ∈ Γ ⟩ →
      ⟨ Γ ⊢ var c : τ1 ↝ τ2 ∷ k ⟩
  | RedTAbs {γ τ1 τ2 k1 k2} :
      ⟨ Γ ► k1 ⊢ γ : τ1 ↝ τ2 ∷ k2 ⟩ →
      ⟨ Γ ⊢ coτabs k1 γ : τabs k1 τ1 ↝ τabs k1 τ2 ∷ karr k1 k2 ⟩
  | RedTApp {γ1 γ2 τ11 τ12 τ21 τ22 k1 k2 }:
      ⟨ Γ ⊢ γ1 : τ11 ↝ τ21 ∷ karr k1 k2 ⟩ →
      ⟨ Γ ⊢ γ2 : τ12 ↝ τ22 ∷ k1 ⟩ →
      ⟨ Γ ⊢ coτapp γ1 γ2 : τapp τ11 τ12 ↝ τapp τ21 τ22 ∷ k2 ⟩
  | RedArr {γ1 γ2 τ11 τ12 τ21 τ22}:
      ⟨ Γ ⊢ γ1 : τ11 ↝ τ21 ∷ kstar ⟩ →
      ⟨ Γ ⊢ γ2 : τ12 ↝ τ22 ∷ kstar ⟩ →
      ⟨ Γ ⊢ coarr γ1 γ2 : arr τ11 τ12 ↝ arr τ21 τ22 ∷ kstar ⟩
  | RedArrτ {γ τ1 τ2 k} :
      ⟨ Γ ► k ⊢ γ : τ1 ↝ τ2 ∷ kstar ⟩ →
      ⟨ Γ ⊢ coarrτ k γ : arrτ k τ1 ↝ arrτ k τ2 ∷ kstar ⟩
  | RedArrγ {γ1 γ2 γ3 τ1 τ1' τ2 τ2' τ3 τ3' k} :
      ⟨ Γ ⊢ γ1 : τ1 ↝ τ1' ∷ k ⟩ →
      ⟨ Γ ⊢ γ2 : τ2 ↝ τ2' ∷ k ⟩ →
      ⟨ Γ ⊢ γ3 : τ3 ↝ τ3' ∷ kstar ⟩ →
      ⟨ Γ ⊢ coarrγ γ1 γ2 k γ3 : arrγ τ1 τ2 k τ3 ↝ arrγ τ1' τ2' k τ3' ∷ kstar ⟩
  | RedBeta {γ1 γ2 τ1 τ2 τ1' τ2' k1 k2} :
      ⟨ Γ ► k1 ⊢ γ1 : τ1 ↝ τ1' ∷ k2 ⟩ →
      ⟨ Γ ⊢ γ2 : τ2 ↝ τ2' ∷ k1 ⟩ →
      ⟨ Γ ⊢ cobeta k1 γ1 γ2 : τapp (τabs k1 τ1) τ2 ↝ τ1'[beta1 τ2'] ∷ k2 ⟩
  | RedReflVar {α k} :
      ⟨ α ∷ k ∈ Γ ⟩ →
      ⟨ Γ ⊢ corefl (var α) : var α ↝ var α ∷ k ⟩
where "⟨ Γ ⊢ γ : τ1 ↝ τ2 ∷ k ⟩" := (Red Γ γ τ1 τ2 k).

Reserved Notation "⟨ Γ ⊢ γs : τ1 ↝* τ2 ∷ k ⟩"
  ( at level 0,
    Γ at level 98,
    γs at level 98,
    τ1 at level 98,
    τ2 at level 98,
    k at level 98).

Inductive RedStar (Γ: Env) : list Exp → Exp → Exp → Kind → Prop :=
  | RedStarNil {τ k}:
      ⟨ Γ ⊢ τ ∷ k ⟩ →
      ⟨ Γ ⊢ nil : τ ↝* τ ∷ k ⟩
  | RedStarCons {τ1 τ2 τ3 γs γ k} :
      ⟨ Γ ⊢ γs : τ1 ↝* τ2 ∷ k ⟩ →
      ⟨ Γ ⊢ γ : τ2 ↝ τ3 ∷ k ⟩ →
      ⟨ Γ ⊢ cons γ γs : τ1 ↝* τ3 ∷ k ⟩
where "⟨ Γ ⊢ γs : τ1 ↝* τ2 ∷ k ⟩" := (RedStar Γ γs τ1 τ2 k).

Reserved Notation "⟨ Γ ⊢ s : τ ⟩"
  ( at level 0,
    Γ at level 98,
    s at level 98,
    τ at level 98).

Inductive Tm (Γ: Env) : Exp → Exp → Prop :=
  | Var {x τ} :
      ⟨ x : τ ∈ Γ ⟩ →
      ⟨ Γ ⊢ var x : τ ⟩
  | Abs {s τ1 τ2} :
      ⟨ Γ ⊢ τ1 ∷ kstar ⟩ →
      ⟨ Γ ▻ τ1 ⊢ s : τ2[wkm] ⟩ →
      ⟨ Γ ⊢ τ2 ∷ kstar ⟩ → (* Remove after adding strengthening lemmas *)
      ⟨ Γ ⊢ abs τ1 s : arr τ1 τ2 ⟩
  | Absτ {s τ k} :
      ⟨ Γ ► k ⊢ s : τ ⟩ →
      ⟨ Γ ⊢ absτ k s : arrτ k τ ⟩
  | Absγ {s τ1 τ2 τ3 k} :
      ⟨ Γ ◅ τ1 ~ τ2 ∷ k ⊢ s : τ3[wkm] ⟩ →
      ⟨ Γ ⊢ τ1 ∷ k ⟩ →
      ⟨ Γ ⊢ τ2 ∷ k ⟩ →
      ⟨ Γ ⊢ τ3 ∷ kstar ⟩ → (* Remove after adding strengthening lemmas *)
      ⟨ Γ ⊢ absγ τ1 τ2 k s : arrγ τ1 τ2 k τ3 ⟩
  | App {s1 s2 τ1 τ2} :
      ⟨ Γ ⊢ s1 : arr τ1 τ2 ⟩ →
      ⟨ Γ ⊢ s2 : τ1 ⟩ →
      ⟨ Γ ⊢ app s1 s2 : τ2 ⟩
  | Appτ {s τ1 τ2 k} :
      ⟨ Γ ⊢ s : arrτ k τ1 ⟩ →
      ⟨ Γ ⊢ τ2 ∷ k ⟩ →
      ⟨ Γ ⊢ appτ s τ2 : τ1[beta1 τ2] ⟩
  | Appγ {s γ τ1 τ2 τ3 k} :
      ⟨ Γ ⊢ s : arrγ τ1 τ2 k τ3 ⟩ →
      ⟨ Γ ⊢ γ : τ1 ~ τ2 ∷ k ⟩ →
      ⟨ Γ ⊢ appγ s γ : τ3 ⟩
  | Cast {s γ τ1 τ2} :
      ⟨ Γ ⊢ s : τ1 ⟩ →
      ⟨ Γ ⊢ γ : τ1 ~ τ2 ∷ kstar ⟩ →
      ⟨ Γ ⊢ cast s γ : τ2 ⟩
where "⟨ Γ ⊢ s : τ ⟩" := (Tm Γ s τ).


(** Wasm AST to binary.
Breaks non-determinism ties; see binary_format_spec.v for the spec. *)
Require Import datatypes_properties numerics.
From compcert Require Integers.
Require Import Byte.
Require leb128.
Require Import Coq.Arith.Le.
From mathcomp Require Import ssreflect ssrfun ssrnat ssrbool eqtype seq.

Definition binary_of_value_type (t : value_type) : byte :=
  match t with
  | T_i32 => x7f
  | T_i64 => x7e
  | T_f32 => x7d
  | T_f64 => x7c
  end.

Definition binary_of_block_type_aux (bt : list value_type) : list byte :=
  match bt with
  | nil => x40 :: nil
  | cons t nil => binary_of_value_type t :: nil
  | _ => (* TODO: this should never occur *) nil
  end.

Definition binary_of_block_type (ft : function_type) : list byte :=
  match ft with
  | Tf nil rt => binary_of_block_type_aux rt
  | _ => (* TODO: should never happen *) nil
  end.

Definition binary_of_u32_nat (n : nat) : list byte :=
  leb128.encode_unsigned (BinNatDef.N.of_nat n).

Definition binary_of_idx n := binary_of_u32_nat n.

Definition binary_of_vec {A} (f : A -> list byte) (es : list A) : list byte :=
  (binary_of_u32_nat (List.length es)) ++ (List.concat (List.map f es)).

Definition binary_of_memarg a o : list byte :=
  binary_of_u32_nat a ++ binary_of_u32_nat o.

Definition binary_of_i32 (x : i32) : list byte :=
  leb128.encode_signed (Wasm_int.Int32.signed x).

Definition binary_of_i64 (x : i64) : list byte :=
  leb128.encode_signed (Wasm_int.Int64.signed x).

Definition binary_of_f32 (x : f32) : list byte :=
  List.map byte_of_compcert_byte (serialise_f32 x).

Definition binary_of_f64 (x : f64) : list byte :=
  List.map byte_of_compcert_byte (serialise_f64 x).

(** An opaque definition for cases that can’t happen because of the well-formed properties. **)
Definition dummy : list byte.
Proof. exact (x00 :: x00 :: x00 :: nil). Qed.

Fixpoint binary_of_be (be : basic_instruction) : list byte :=
  let binary_of_instrs bes := List.concat (List.map binary_of_be bes) in
  match be with
  | BI_unreachable => x00 :: nil
  | BI_nop => x01 :: nil
  | BI_block rt ins =>
    x02 :: binary_of_block_type rt ++ binary_of_instrs ins ++ x0b :: nil
  | BI_loop rt ins =>
    x03 :: binary_of_block_type rt ++ binary_of_instrs ins ++ x0b :: nil
  | BI_if rt ins nil =>
    x04 :: binary_of_block_type rt ++ binary_of_instrs ins ++ x0b :: nil
  | BI_if rt ins1 ins2 =>
    x04 :: binary_of_block_type rt ++ binary_of_instrs ins1 ++ x05 :: nil ++ binary_of_instrs ins2 ++ x0b :: nil
  | BI_br l => x0c :: binary_of_idx l
  | BI_br_if l => x0d :: binary_of_idx l
  | BI_br_table ls l_N =>
    x0e :: binary_of_vec binary_of_idx ls ++ binary_of_idx l_N
  | BI_return => x0f :: nil
  | BI_call x => x10 :: binary_of_idx x
  | BI_call_indirect x => x11 :: binary_of_idx x ++ x00 :: nil
  | BI_drop => x1a :: nil
  | BI_select => x1b :: nil
  | BI_get_local x => x20 :: binary_of_idx x
  | BI_set_local x => x21 :: binary_of_idx x
  | BI_tee_local x => x22 :: binary_of_idx x
  | BI_get_global x => x23 :: binary_of_idx x
  | BI_set_global x => x24 :: binary_of_idx x
  | BI_load T_i32 None a o => x28 :: binary_of_memarg a o
  | BI_load T_i64 None a o => x29 :: binary_of_memarg a o
  | BI_load T_f32 None a o => x2a :: binary_of_memarg a o
  | BI_load T_f32 (Some _) _ _ => dummy
  | BI_load T_f64 None a o => x2b :: binary_of_memarg a o
  | BI_load T_f64 (Some _) _ _ => dummy
  | BI_load T_i32 (Some (Tp_i8, SX_S)) a o => x2c :: binary_of_memarg a o
  | BI_load T_i32 (Some (Tp_i8, SX_U)) a o => x2d :: binary_of_memarg a o
  | BI_load T_i32 (Some (Tp_i16, SX_S)) a o => x2e :: binary_of_memarg a o
  | BI_load T_i32 (Some (Tp_i16, SX_U)) a o => x2f :: binary_of_memarg a o
  | BI_load T_i32 (Some (Tp_i32, _)) _ _ => dummy
  | BI_load T_i64 (Some (Tp_i8, SX_S)) a o => x30 :: binary_of_memarg a o
  | BI_load T_i64 (Some (Tp_i8, SX_U)) a o => x31 :: binary_of_memarg a o
  | BI_load T_i64 (Some (Tp_i16, SX_S)) a o => x32 :: binary_of_memarg a o
  | BI_load T_i64 (Some (Tp_i16, SX_U)) a o => x33 :: binary_of_memarg a o
  | BI_load T_i64 (Some (Tp_i32, SX_S)) a o => x34 :: binary_of_memarg a o
  | BI_load T_i64 (Some (Tp_i32, SX_U)) a o => x35 :: binary_of_memarg a o
  | BI_store T_i32 None a o => x36 :: binary_of_memarg a o
  | BI_store T_i64 None a o => x37 :: binary_of_memarg a o
  | BI_store T_f32 None a o => x38 :: binary_of_memarg a o
  | BI_store T_f32 (Some _) _ _  => dummy
  | BI_store T_f64 None a o => x39 :: binary_of_memarg a o
  | BI_store T_f64 (Some _) _ _ => dummy
  | BI_store T_i32 (Some Tp_i8) a o => x3a :: binary_of_memarg a o
  | BI_store T_i32 (Some Tp_i16) a o => x3b :: binary_of_memarg a o
  | BI_store T_i32 (Some Tp_i32) _ _ => dummy
  | BI_store T_i64 (Some Tp_i8) a o => x3c :: binary_of_memarg a o
  | BI_store T_i64 (Some Tp_i16) a o => x3d :: binary_of_memarg a o
  | BI_store T_i64 (Some Tp_i32) a o => x3e :: binary_of_memarg a o
  | BI_current_memory => x3f :: x00 :: nil
  | BI_grow_memory => x40 :: x00 :: nil
  | BI_const (VAL_int32 x) => x41 :: binary_of_i32 x
  | BI_const (VAL_int64 x) => x42 :: binary_of_i64 x
  | BI_const (VAL_float32 x) => x43 :: binary_of_f32 x
  | BI_const (VAL_float64 x) => x44 :: binary_of_f64 x
  | BI_testop T_i32 Eqz => x45 :: nil
  | BI_testop T_i64 Eqz => x50 :: nil
  | BI_testop T_f32 _ => dummy
  | BI_testop T_f64 _ => dummy
  | BI_relop T_i32 (Relop_i ROI_eq) => x46 :: nil
  | BI_relop T_i32 (Relop_i ROI_ne) => x47 :: nil
  | BI_relop T_i32 (Relop_i (ROI_lt SX_S)) => x48 :: nil
  | BI_relop T_i32 (Relop_i (ROI_lt SX_U)) => x49 :: nil
  | BI_relop T_i32 (Relop_i (ROI_gt SX_S)) => x4a :: nil
  | BI_relop T_i32 (Relop_i (ROI_gt SX_U)) => x4b :: nil
  | BI_relop T_i32 (Relop_i (ROI_le SX_S)) => x4c :: nil
  | BI_relop T_i32 (Relop_i (ROI_le SX_U)) => x4d :: nil
  | BI_relop T_i32 (Relop_i (ROI_ge SX_S)) => x4e :: nil
  | BI_relop T_i32 (Relop_i (ROI_ge SX_U)) => x4f :: nil
  | BI_relop T_i64 (Relop_i ROI_eq) => x51 :: nil
  | BI_relop T_i64 (Relop_i ROI_ne) => x52 :: nil
  | BI_relop T_i64 (Relop_i (ROI_lt SX_S)) => x53 :: nil
  | BI_relop T_i64 (Relop_i (ROI_lt SX_U)) => x54 :: nil
  | BI_relop T_i64 (Relop_i (ROI_gt SX_S)) => x55 :: nil
  | BI_relop T_i64 (Relop_i (ROI_gt SX_U)) => x56 :: nil
  | BI_relop T_i64 (Relop_i (ROI_le SX_S)) => x57 :: nil
  | BI_relop T_i64 (Relop_i (ROI_le SX_U)) => x58 :: nil
  | BI_relop T_i64 (Relop_i (ROI_ge SX_S)) => x59 :: nil
  | BI_relop T_i64 (Relop_i (ROI_ge SX_U)) => x5a :: nil
  | BI_relop T_f32 (Relop_i _) => dummy
  | BI_relop T_f64 (Relop_i _) => dummy
  | BI_relop T_f32 (Relop_f ROF_eq) => x5b :: nil
  | BI_relop T_f32 (Relop_f ROF_ne) => x5c :: nil
  | BI_relop T_f32 (Relop_f ROF_lt) => x5d :: nil
  | BI_relop T_f32 (Relop_f ROF_gt) => x5e :: nil
  | BI_relop T_f32 (Relop_f ROF_le) => x5f :: nil
  | BI_relop T_f32 (Relop_f ROF_ge) => x60 :: nil
  | BI_relop T_f64 (Relop_f ROF_eq) => x61 :: nil
  | BI_relop T_f64 (Relop_f ROF_ne) => x62 :: nil
  | BI_relop T_f64 (Relop_f ROF_lt) => x63 :: nil
  | BI_relop T_f64 (Relop_f ROF_gt) => x64 :: nil
  | BI_relop T_f64 (Relop_f ROF_le) => x65 :: nil
  | BI_relop T_f64 (Relop_f ROF_ge) => x66 :: nil
  | BI_relop T_i32 (Relop_f _) => dummy
  | BI_relop T_i64 (Relop_f _) => dummy
  | BI_unop T_i32 (Unop_i UOI_clz) => x67 :: nil
  | BI_unop T_i32 (Unop_i UOI_ctz) => x68 :: nil
  | BI_unop T_i32 (Unop_i UOI_popcnt) => x69 :: nil
  | BI_binop T_i32 (Binop_i BOI_add) => x6a :: nil
  | BI_binop T_i32 (Binop_i BOI_sub) => x6b :: nil
  | BI_binop T_i32 (Binop_i BOI_mul) => x6c :: nil
  | BI_binop T_i32 (Binop_i (BOI_div SX_S)) => x6d :: nil
  | BI_binop T_i32 (Binop_i (BOI_div SX_U)) => x6e :: nil
  | BI_binop T_i32 (Binop_i (BOI_rem SX_S)) => x6f :: nil
  | BI_binop T_i32 (Binop_i (BOI_rem SX_U)) => x70 :: nil
  | BI_binop T_i32 (Binop_i BOI_and) => x71 :: nil
  | BI_binop T_i32 (Binop_i BOI_or) => x72 :: nil
  | BI_binop T_i32 (Binop_i BOI_xor) => x73 :: nil
  | BI_binop T_i32 (Binop_i BOI_shl) => x74 :: nil
  | BI_binop T_i32 (Binop_i (BOI_shr SX_S)) => x75 :: nil
  | BI_binop T_i32 (Binop_i (BOI_shr SX_U)) => x76 :: nil
  | BI_binop T_i32 (Binop_i BOI_rotl) => x77 :: nil
  | BI_binop T_i32 (Binop_i BOI_rotr) => x78 :: nil
  | BI_binop T_f32 (Binop_i _) => dummy
  | BI_binop T_f64 (Binop_i _) => dummy
  | BI_unop T_i64 (Unop_i UOI_clz) => x79 :: nil
  | BI_unop T_i64 (Unop_i UOI_ctz) => x7a :: nil
  | BI_unop T_i64 (Unop_i UOI_popcnt) => x7b :: nil
  | BI_unop T_f32 (Unop_i _) => dummy
  | BI_unop T_f64 (Unop_i _) => dummy
  | BI_binop T_i64 (Binop_i BOI_add) => x7c :: nil
  | BI_binop T_i64 (Binop_i BOI_sub) => x7d :: nil
  | BI_binop T_i64 (Binop_i BOI_mul) => x7e :: nil
  | BI_binop T_i64 (Binop_i (BOI_div SX_S)) => x7f :: nil
  | BI_binop T_i64 (Binop_i (BOI_div SX_U)) => x80 :: nil
  | BI_binop T_i64 (Binop_i (BOI_rem SX_S)) => x81 :: nil
  | BI_binop T_i64 (Binop_i (BOI_rem SX_U)) => x82 :: nil
  | BI_binop T_i64 (Binop_i BOI_and) => x83 :: nil
  | BI_binop T_i64 (Binop_i BOI_or) => x84 :: nil
  | BI_binop T_i64 (Binop_i BOI_xor) => x85 :: nil
  | BI_binop T_i64 (Binop_i BOI_shl) => x86 :: nil
  | BI_binop T_i64 (Binop_i (BOI_shr SX_S)) => x87 :: nil
  | BI_binop T_i64 (Binop_i (BOI_shr SX_U)) => x88 :: nil
  | BI_binop T_i64 (Binop_i BOI_rotl) => x89 :: nil
  | BI_binop T_i64 (Binop_i BOI_rotr) => x8a :: nil
  | BI_unop T_f32 (Unop_f UOF_abs) => x8b :: nil
  | BI_unop T_f32 (Unop_f UOF_neg) => x8c :: nil
  | BI_unop T_f32 (Unop_f UOF_ceil) => x8d :: nil
  | BI_unop T_f32 (Unop_f UOF_floor) => x8e :: nil
  | BI_unop T_f32 (Unop_f UOF_trunc) => x8f :: nil
  | BI_unop T_f32 (Unop_f UOF_nearest) => x90 :: nil
  | BI_unop T_f32 (Unop_f UOF_sqrt) => x91 :: nil
  | BI_unop T_i32 (Unop_f _) => dummy
  | BI_unop T_i64 (Unop_f _) => dummy
  | BI_binop T_f32 (Binop_f BOF_add) => x92 :: nil
  | BI_binop T_f32 (Binop_f BOF_sub) => x93 :: nil
  | BI_binop T_f32 (Binop_f BOF_mul) => x94 :: nil
  | BI_binop T_f32 (Binop_f BOF_div) => x95 :: nil
  | BI_binop T_f32 (Binop_f BOF_min) => x96 :: nil
  | BI_binop T_f32 (Binop_f BOF_max) => x97 :: nil
  | BI_binop T_f32 (Binop_f BOF_copysign) => x98 :: nil
  | BI_unop T_f64 (Unop_f UOF_abs) => x99 :: nil
  | BI_unop T_f64 (Unop_f UOF_neg) => x9a :: nil
  | BI_unop T_f64 (Unop_f UOF_ceil) => x9b :: nil
  | BI_unop T_f64 (Unop_f UOF_floor) => x9c :: nil
  | BI_unop T_f64 (Unop_f UOF_trunc) => x9d :: nil
  | BI_unop T_f64 (Unop_f UOF_nearest) => x9e :: nil
  | BI_unop T_f64 (Unop_f UOF_sqrt) => x9f :: nil
  | BI_binop T_f64 (Binop_f BOF_add) => xa0 :: nil
  | BI_binop T_f64 (Binop_f BOF_sub) => xa1 :: nil
  | BI_binop T_f64 (Binop_f BOF_mul) => xa2 :: nil
  | BI_binop T_f64 (Binop_f BOF_div) => xa3 :: nil
  | BI_binop T_f64 (Binop_f BOF_min) => xa4 :: nil
  | BI_binop T_f64 (Binop_f BOF_max) => xa5 :: nil
  | BI_binop T_f64 (Binop_f BOF_copysign) => xa6 :: nil
  | BI_binop T_i32 (Binop_f _) => dummy
  | BI_binop T_i64 (Binop_f _) => dummy
  (* TODO: I am really not sure whether the cases below are right :-s *)
  | BI_cvtop T_i32 CVO_convert T_i64 (Some SX_U) (* TODO: is this correct? *) => xa7 :: nil
  | BI_cvtop T_i32 CVO_convert T_i64 _ => dummy
  | BI_cvtop T_i32 CVO_convert T_f32 (Some SX_S) => xa8 :: nil
  | BI_cvtop T_i32 CVO_convert T_f32 (Some SX_U) => xa9 :: nil
  | BI_cvtop T_i32 CVO_convert T_f32 None => dummy
  | BI_cvtop T_i32 CVO_convert T_f64 (Some SX_S) => xaa :: nil
  | BI_cvtop T_i32 CVO_convert T_f64 (Some SX_U) => xab :: nil
  | BI_cvtop T_i32 CVO_convert T_f64 None => dummy
  | BI_cvtop T_i32 CVO_convert T_i32 _ => dummy
  | BI_cvtop T_i64 CVO_convert T_i32 (Some SX_S) => xac :: nil
  | BI_cvtop T_i64 CVO_convert T_i32 (Some SX_U) => xad :: nil
  | BI_cvtop T_i64 CVO_convert T_i32 None => dummy
  | BI_cvtop T_i64 CVO_convert T_f32 (Some SX_S) => xae :: nil
  | BI_cvtop T_i64 CVO_convert T_f32 (Some SX_U) => xaf :: nil
  | BI_cvtop T_i64 CVO_convert T_f32 None => dummy
  | BI_cvtop T_i64 CVO_convert T_f64 (Some SX_S) => xb0 :: nil
  | BI_cvtop T_i64 CVO_convert T_f64 (Some SX_U) => xb1 :: nil
  | BI_cvtop T_i64 CVO_convert T_f64 _ => dummy
  | BI_cvtop T_i64 CVO_convert T_i64 _ => dummy
  | BI_cvtop T_f32 CVO_convert T_i32 (Some SX_S) => xb2 :: nil
  | BI_cvtop T_f32 CVO_convert T_i32 (Some SX_U) => xb3 :: nil
  | BI_cvtop T_f32 CVO_convert T_i32 None => dummy
  | BI_cvtop T_f32 CVO_convert T_i64 (Some SX_S) => xb4 :: nil
  | BI_cvtop T_f32 CVO_convert T_i64 (Some SX_U) => xb5 :: nil
  | BI_cvtop T_f32 CVO_convert T_i64 None => dummy
  | BI_cvtop T_f32 CVO_convert T_f64 None => xb6 :: nil
  | BI_cvtop T_f32 CVO_convert T_f64 (Some _) => dummy
  | BI_cvtop T_f32 CVO_convert T_f32 _ => dummy
  | BI_cvtop T_f64 CVO_convert T_i32 (Some SX_S) => xb7 :: nil
  | BI_cvtop T_f64 CVO_convert T_i32 (Some SX_U) => xb8 :: nil
  | BI_cvtop T_f64 CVO_convert T_i32 None => dummy
  | BI_cvtop T_f64 CVO_convert T_i64 (Some SX_S) => xb9 :: nil
  | BI_cvtop T_f64 CVO_convert T_i64 (Some SX_U) => xba :: nil
  | BI_cvtop T_f64 CVO_convert T_i64 None => dummy
  | BI_cvtop T_f64 CVO_convert T_f32 None => xbb :: nil
  | BI_cvtop T_f64 CVO_convert T_f32 (Some _) => dummy
  | BI_cvtop T_f64 CVO_convert T_f64 _ => dummy
  | BI_cvtop T_i32 CVO_reinterpret T_f32 None => xbc :: nil
  | BI_cvtop T_i64 CVO_reinterpret T_f64 None => xbc :: nil
  | BI_cvtop T_f32 CVO_reinterpret T_i32 None => xbc :: nil
  | BI_cvtop T_f64 CVO_reinterpret T_i64 None => xbc :: nil
  | BI_cvtop T_i32 CVO_reinterpret T_i32 _ => dummy
  | BI_cvtop T_i32 CVO_reinterpret T_i64 _ => dummy
  | BI_cvtop T_i32 CVO_reinterpret T_f64 _ => dummy
  | BI_cvtop T_i64 CVO_reinterpret T_i32 _ => dummy
  | BI_cvtop T_i64 CVO_reinterpret T_i64 _ => dummy
  | BI_cvtop T_i64 CVO_reinterpret T_f32 _ => dummy
  | BI_cvtop T_f32 CVO_reinterpret T_i64 _ => dummy
  | BI_cvtop T_f32 CVO_reinterpret T_f32 _ => dummy
  | BI_cvtop T_f32 CVO_reinterpret T_f64 _ => dummy
  | BI_cvtop T_f64 CVO_reinterpret T_i32 _ => dummy
  | BI_cvtop T_f64 CVO_reinterpret T_f32 _ => dummy
  | BI_cvtop T_f64 CVO_reinterpret T_f64 _ => dummy
  | BI_cvtop _ CVO_reinterpret _ (Some _) => dummy
  end.

(** Expressions are encoded by their instruction sequence terminated with an
explicit `0x0B` opcode for `end`. *)
Definition binary_of_expr (bes : list basic_instruction) : list byte  :=
  List.concat (List.map binary_of_be bes) ++ x0b :: nil.

Definition magic : list byte :=
  x00 :: x61 :: x73 :: x6d:: nil.

Definition version : list byte :=
  x01 :: x00 :: x00 :: x00 :: nil.

Definition with_length (bs : list byte) : list byte :=
  leb128.encode_unsigned (bin_of_nat (List.length bs)) ++ bs.

Definition binary_of_result_type rt : list byte :=
  binary_of_vec(fun v => binary_of_value_type v :: nil) rt.

Definition binary_of_functype (ft : function_type) : list byte :=
  let 'Tf rt1 rt2 := ft in
  x60 :: binary_of_result_type rt1 ++ binary_of_result_type rt2.

Definition binary_of_typesec (ts : list function_type) : list byte :=
  x01 :: with_length (binary_of_vec binary_of_functype ts).

Definition binary_of_typeidx (t : typeidx) : list byte :=
  let 'Mk_typeidx i := t in
  leb128.encode_unsigned (bin_of_nat i).

Definition binary_of_funcidx (t : funcidx) : list byte :=
  let 'Mk_funcidx i := t in
  leb128.encode_unsigned (bin_of_nat i).

Definition binary_of_tableidx (t : tableidx) : list byte :=
  let 'Mk_tableidx i := t in
  leb128.encode_unsigned (bin_of_nat i).

Definition binary_of_memidx (t : memidx) : list byte :=
  let 'Mk_memidx i := t in
  leb128.encode_unsigned (bin_of_nat i).

Definition binary_of_globalidx (t : globalidx) : list byte :=
  let 'Mk_globalidx i := t in
  leb128.encode_unsigned (bin_of_nat i).

Definition binary_of_name (n : name) : list byte :=
  binary_of_vec (fun n => cons n nil) n.

Definition binary_of_elem_type (et : elem_type) : list byte :=
  match et with
  | ET_funcref => cons x70 nil
  end.

Definition binary_of_limits (l : limits) : list byte :=
  match l.(lim_max) with
  | None => x00 :: leb128.encode_unsigned (bin_of_nat l.(lim_min))
  | Some max =>
    x01 ::
    leb128.encode_unsigned (bin_of_nat l.(lim_min)) ++
    leb128.encode_unsigned (bin_of_nat max)
  end.

Definition binary_of_table_type (t_ty : table_type) : list byte :=
  binary_of_elem_type t_ty.(tt_elem_type) ++
  binary_of_limits t_ty.(tt_limits).

Definition binary_of_mutability (m : mutability) : list byte :=
  match m with
  | MUT_immut => cons x00 nil
  | MUT_mut => cons x01 nil
  end.

Definition binary_of_global_type (g_ty : global_type) : list byte :=
  cons (binary_of_value_type g_ty.(tg_t)) nil ++
  binary_of_mutability g_ty.(tg_mut).

Definition binary_of_memory_type (m : memory_type) : list byte :=
  binary_of_limits m.

Definition binary_of_import_desc (imp_desc : import_desc) : list byte :=
  match imp_desc with
  | ID_func tidx => x00 :: binary_of_typeidx (Mk_typeidx tidx)
  | ID_table t_ty => x01 :: binary_of_table_type t_ty
  | ID_mem m_ty => x02 :: binary_of_memory_type m_ty
  | ID_global g_ty => x03 :: binary_of_global_type g_ty
  end.

Definition binary_of_module_import (imp : module_import) : list byte :=
  binary_of_name imp.(imp_module) ++
  binary_of_name imp.(imp_name) ++
  binary_of_import_desc imp.(imp_desc).

Definition binary_of_importsec (imps : list module_import) : list byte :=
  x02 :: with_length (binary_of_vec binary_of_module_import imps).

Definition binary_of_funcsec (fs : list module_func) : list byte :=
  x03 :: with_length (binary_of_vec binary_of_typeidx (List.map (fun f => f.(modfunc_type)) fs)).

Definition binary_of_module_table (t : module_table) : list byte :=
  binary_of_table_type t.(modtab_type).

Definition binary_of_tablesec (ts : list module_table) : list byte :=
  x04 :: with_length (binary_of_vec binary_of_module_table ts).

Definition binary_of_memsec (ms : list memory_type) : list byte :=
  x05 :: with_length (binary_of_vec binary_of_memory_type ms).

Definition binary_of_module_glob (g : module_glob) : list byte :=
  binary_of_global_type g.(modglob_type) ++
  binary_of_expr g.(modglob_init).

Definition binary_of_globalsec (gs : list module_glob) : list byte :=
  x06 :: with_length (binary_of_vec binary_of_module_glob gs).

Definition binary_of_export_desc (ed : module_export_desc) : list byte :=
  match ed with
  | MED_func n => x00 :: binary_of_funcidx n
  | MED_table n => x01 :: binary_of_tableidx n
  | MED_mem n => x02 :: binary_of_memidx n
  | MED_global n => x03 :: binary_of_globalidx n
  end.

Definition binary_of_module_export (e : module_export) : list byte :=
  binary_of_name e.(modexp_name) ++
  binary_of_export_desc e.(modexp_desc).

Definition binary_of_exportssec (es : list module_export) : list byte :=
  x07 :: with_length (binary_of_vec binary_of_module_export es).

Definition binary_of_module_start (s : module_start) : list byte :=
  binary_of_funcidx s.(modstart_func).

Definition binary_of_startsec (s : module_start) : list byte :=
  x08 :: with_length (binary_of_module_start s).

Definition binary_of_module_elem (e : module_element) : list byte :=
  binary_of_tableidx e.(modelem_table) ++
  binary_of_expr e.(modelem_offset) ++
  binary_of_vec binary_of_funcidx e.(modelem_init).

Definition binary_of_elemsec (es : list module_element) : list byte :=
  x09 :: with_length (binary_of_vec binary_of_module_elem es).

Definition binary_of_local (n_t : nat * value_type) : list byte :=
  let '(n, t) := n_t in
  leb128.encode_unsigned (bin_of_nat n) ++
  cons (binary_of_value_type t) nil.

Fixpoint bunch_locals_aux (cur_ty : value_type) (cur_count : nat) (acc : list (nat * value_type)) (tys : list value_type) : list (nat * value_type) :=
  match tys with
  | nil => List.rev ((cur_count, cur_ty) :: acc)
  | cons ty tys' =>
    if cur_ty == ty then bunch_locals_aux cur_ty (cur_count + 1) acc tys'
    else bunch_locals_aux ty 1 ((cur_count, cur_ty) :: acc) tys'
  end.

Definition bunch_locals (tys : list value_type) : list (nat * value_type) :=
  match tys with
  | nil => nil
  | cons ty tys' => bunch_locals_aux ty 1 nil tys'
  end.

Definition binary_of_code_func (cf : code_func) : list byte :=
  binary_of_vec binary_of_local (bunch_locals cf.(fc_locals)) ++
  binary_of_expr cf.(fc_expr).

Definition binary_of_code (mf : module_func) : list byte :=
  let func := {| fc_locals := mf.(modfunc_locals); fc_expr := mf.(modfunc_body) |} in
  let func_bin := binary_of_code_func func in
  let func_len := List.length func_bin in
  leb128.encode_unsigned (bin_of_nat func_len) ++
  func_bin.

Definition binary_of_codesec (fs : list module_func) : list byte :=
  x0a :: with_length (binary_of_vec binary_of_code fs).

Definition binary_of_data (d : module_data) : list byte :=
  binary_of_memidx d.(moddata_data) ++
  binary_of_expr d.(moddata_offset) ++
  binary_of_vec (fun x => cons x nil) d.(moddata_init).

Definition binary_of_datasec (ds : list module_data) : list byte :=
  x0b :: with_length (binary_of_vec binary_of_data ds).

Definition only_if_non_nil {A} (f : list A -> list byte) (xs : list A) : list byte :=
  match xs with
  | nil => nil
  | _ :: _ => f xs
  end.

Definition only_if_non_none {A} (f : A -> list byte) (xo : option A) : list byte :=
  match xo with
  | None => nil
  | Some x => f x
  end.

Definition binary_of_module (m : module) : list byte :=
  magic ++ version ++
  only_if_non_nil binary_of_typesec m.(mod_types) ++
  only_if_non_nil binary_of_importsec m.(mod_imports) ++
  only_if_non_nil binary_of_funcsec m.(mod_funcs) ++
  only_if_non_nil binary_of_tablesec m.(mod_tables) ++
  only_if_non_nil binary_of_memsec m.(mod_mems) ++
  only_if_non_nil binary_of_globalsec m.(mod_globals) ++
  only_if_non_nil binary_of_exportssec m.(mod_exports) ++
  only_if_non_none binary_of_startsec m.(mod_start) ++
  only_if_non_nil binary_of_elemsec m.(mod_elem) ++
  only_if_non_nil binary_of_codesec m.(mod_funcs) ++
  only_if_non_nil binary_of_datasec m.(mod_data).