(* 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                                                     *)

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

(* The cartesian product and its properties *)

Require Import Sets.
Require Import Axioms.

(* This definition of the ordered pair is slightly different from *)
(* the usual one, since we want it to work in an intuisionistic   *)
(* setting. Works the same, neitherless. The soundness proofs are *)
(* unpleasant.                                                    *)

Definition Couple (E E' : Ens) := Paire (Sing E) (Paire Vide (Sing E')).

Theorem Couple_inj_left :
 forall A A' B B' : Ens, EQ (Couple A A') (Couple B B') -> EQ A B.
unfold Couple in |- *; simpl in |- *.
simple induction 1.
intros HA HB; elim (HA true).
intros x; elim x; simpl in |- *; simple induction 1; intros H3 H4;
 elim (H3 true); simpl in |- *; intros xx; elim xx;
 simpl in |- *; auto with zfc.
elim (H4 false); simpl in |- *.
simple induction x0; simpl in |- *.
intros.
cut (EQ (Sing B') Vide).
simpl in |- *.
simple induction 1.
intros yy; elim (yy true).
simple induction x1.

apply EQ_tran with A; auto with zfc.

intros; cut (EQ (Sing B') Vide).
simpl in |- *.
simple induction 1.
intros yy; elim (yy true).
simple induction x1.

apply EQ_tran with A; auto with zfc.

intros yy.
elim (HB true); simpl in |- *.
simple induction x0.
change (EQ (Sing A) (Sing B) -> EQ A B) in |- *; intros EE.
apply IN_Sing_EQ.
apply IN_sound_right with (Sing A); auto with zfc.
change (EQ (Paire Vide (Sing A')) (Sing B) -> EQ A B) in |- *.
intros zz.
elimtype F.
apply (not_EQ_Sing_Vide A').
apply EQ_tran with B.
apply IN_Sing_EQ.
apply IN_sound_right with (Paire Vide (Sing A')); auto with zfc.
apply EQ_sym; apply IN_Sing_EQ;
 apply IN_sound_right with (Paire Vide (Sing A'));
 auto with zfc.

Qed.

Theorem Couple_inj_right :
 forall A A' B B' : Ens, EQ (Couple A A') (Couple B B') -> EQ A' B'.
unfold Couple in |- *; simpl in |- *.
simple induction 1; intros H1 H2.
elim (H1 false).
intros bb1; elim bb1.
intros HF.
change (EQ (Paire Vide (Sing A')) (Sing B)) in HF.
cut F.
simple induction 1.
apply (not_EQ_Vide_Sing A').
apply EQ_tran with B.
apply IN_Sing_EQ; apply IN_sound_right with (Paire Vide (Sing A'));
 auto with zfc.
apply EQ_sym; apply IN_Sing_EQ;
 apply IN_sound_right with (Paire Vide (Sing A'));
 auto with zfc.
change (EQ (Paire Vide (Sing A')) (Paire Vide (Sing B')) -> EQ A' B') in |- *.
intros HP; cut (EQ (Sing A') (Sing B')).
intros; auto with zfc.
cut (IN (Sing A') (Paire Vide (Sing B'))).
intros HI; elim (Paire_IN Vide (Sing B') (Sing A') HI).
intros; cut F.
simple induction 1.
apply not_EQ_Sing_Vide with A'; assumption.
trivial with zfc.
apply IN_sound_right with (Paire Vide (Sing A')); auto with zfc.

Qed.

(* Here we cheat. It is easier to define the cartesian product using    *)
(* the type theoretical product, i.e. we here use non set-theoretical   *)
(* constructions. We could however use the usual definitions.           *)

Definition Prod (E E' : Ens) : Ens :=
  match E, E' with
  | sup A f, sup A' f' =>
      sup _
        (fun c : prod_t A A' =>
         match c with
         | pair_t a a' => Couple (f a) (f' a')
         end)
  end.

Hint Resolve Paire_sound_left Paire_sound_right: zfc.

Theorem Couple_sound_left :
 forall A A' B : Ens, EQ A A' -> EQ (Couple A B) (Couple A' B).
 unfold Couple in |- *; intros; auto with zfc.
Qed.

Theorem Couple_sound_right :
 forall A B B' : Ens, EQ B B' -> EQ (Couple A B) (Couple A B').
 unfold Couple in |- *; intros; auto with zfc.
Qed.

Theorem Couple_IN_Prod :
 forall E1 E2 E1' E2' : Ens,
 IN E1' E1 -> IN E2' E2 -> IN (Couple E1' E2') (Prod E1 E2).
simple induction E1; intros A1 f1 r1; simple induction E2; intros A2 f2 r2.
intros E1' E2' i1 i2.
elim (IN_EXType (sup A1 f1) E1').
intros x e1; simpl in x.
elim (IN_EXType (sup A2 f2) E2').
intros x0 e2; simpl in x.
apply IN_sound_left with (Couple (pi2 (sup A1 f1) x) (pi2 (sup A2 f2) x0));
 auto with zfc.
apply EQ_tran with (Couple (pi2 (sup A1 f1) x) E2'); auto with zfc.
apply Couple_sound_right.
auto with zfc.

apply Couple_sound_left; auto with zfc.

simpl in |- *.
simpl in |- *.
exists (pair_t _ _ x x0).
simpl in |- *.
split.
simple induction x1; simpl in |- *.
exists true; simpl in |- *.
split.
simple induction x2; simpl in |- *.
exists true; auto with zfc.

exists true; auto with zfc.

simple induction y; exists true; auto with zfc.

exists false; simpl in |- *.
split.
simple induction x2.
exists true; simpl in |- *; auto with zfc.
split.
simple induction x3.

simple induction y.

exists false; auto with zfc.

simple induction y; simpl in |- *.
exists true; auto with zfc.

exists false; auto with zfc.

simple induction y; simpl in |- *.
exists true; auto with zfc.

exists false; auto with zfc.

auto with zfc.

auto with zfc.
Qed.

Theorem Couple_Prod_IN :
 forall E1 E2 E1' E2' : Ens,
 IN (Couple E1' E2') (Prod E1 E2) -> IN E1' E1 /\ IN E2' E2.
simple induction E1; intros A1 f1 r1; simple induction E2; intros A2 f2 r2.
intros E1' E2' i.
elim (IN_EXType (Prod (sup A1 f1) (sup A2 f2)) (Couple E1' E2') i).
intros xx; elim xx; intros a1 a2 e.
change (EQ (Couple E1' E2') (Couple (f1 a1) (f2 a2))) in e.
cut (EQ E1' (f1 a1)).
cut (EQ E2' (f2 a2)).
intros e1 e2.
split.
apply IN_sound_left with (f1 a1); auto with zfc; simpl in |- *; exists a1;
 auto with zfc.
apply IN_sound_left with (f2 a2); auto with zfc; simpl in |- *; exists a2;
 auto with zfc.
apply Couple_inj_right with (A := E1') (B := f1 a1); auto with zfc.
apply Couple_inj_left with E2' (f2 a2); auto with zfc.
Qed.

Theorem IN_Prod_EXType :
 forall E E' E'' : Ens,
 IN E'' (Prod E E') ->
 EXType _ (fun A : Ens => EXType _ (fun B : Ens => EQ (Couple A B) E'')).
simple induction E; intros A f r; simple induction E'; intros A' f' r'.
intros; elim (IN_EXType (Prod (sup A f) (sup A' f')) E'').
simple induction x.
intros; exists (f a); exists (f' b); auto with zfc.
auto with zfc.
Qed.


(* 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                                                     *)

Require Import Peano_dec.
Require Import Transitive_Closure.
Require Import Union.
Require Import Termes.
Require Import Conv.

  Definition ord_norm1 := union _ subterm (transp _ red1).
  Definition ord_norm := clos_trans _ ord_norm1.

  Hint Unfold ord_norm1 ord_norm: coc.

  Lemma subterm_ord_norm : forall a b : term, subterm a b -> ord_norm a b.
auto 10 with coc sets.
Qed.

  Hint Resolve subterm_ord_norm: coc.

  Lemma red_red1_ord_norm :
   forall a b : term, red a b -> forall c : term, red1 b c -> ord_norm c a.
red in |- *.
simple induction 1; intros; auto with coc sets.
apply t_trans with N; auto with coc sets.
Qed.

  Lemma wf_subterm : well_founded subterm.
red in |- *.
simple induction a; intros; apply Acc_intro; intros.
inversion_clear H; inversion_clear H0.

inversion_clear H; inversion_clear H0.

inversion_clear H1; inversion_clear H2; auto with coc sets.

inversion_clear H1; inversion_clear H2; auto with coc sets.

inversion_clear H1; inversion_clear H2; auto with coc sets.
Qed.

  Lemma wf_ord_norm1 : forall t : term, sn t -> Acc ord_norm1 t.
unfold ord_norm1 in |- *.
intros.
apply Acc_union; auto with coc sets.
exact commut_red1_subterm.

intros.
apply wf_subterm.
Qed.

  Theorem wf_ord_norm : forall t : term, sn t -> Acc ord_norm t.
unfold ord_norm in |- *.
intros.
apply Acc_clos_trans.
apply wf_ord_norm1; auto with coc sets.
Qed.

  Definition norm_body (a : term) (norm : term -> term) :=
    match a with
    | Srt s => Srt s
    | Ref n => Ref n
    | Abs T t => Abs (norm T) (norm t)
    | App u v =>
        match norm u return term with
        | Abs _ b => norm (subst (norm v) b)
        | t => App t (norm v)
        end
    | Prod T U => Prod (norm T) (norm U)
    end.

  Definition compute_nf :
   forall t : term, sn t -> {u : term | red t u &  normal u}.
Proof.
intros.
elimtype (Acc ord_norm t).
clear H t.
intros [s| n| T t| u v| T U] _ norm_rec.
exists (Srt s); auto with coc.
red in |- *; red in |- *; intros.
inversion_clear H.

exists (Ref n); auto with coc.
red in |- *; red in |- *; intros.
inversion_clear H.

elim norm_rec with T; auto with coc; intros T' redT nT.
elim norm_rec with t; auto with coc; intros t' redt nt.
exists (Abs T' t'); auto with coc.
red in |- *; red in |- *; intros.
inversion_clear H.
elim nT with M'; trivial.
elim nt with M'; trivial.

elim norm_rec with v; auto with coc; intros v' redv nv.
elim norm_rec with u; auto with coc.
intros [s| n| T t| a b| T U] redu nu.
exists (App (Srt s) v'); auto with coc.
red in |- *; red in |- *; intros.
inversion_clear H.
inversion_clear H0.
elim nv with N2; trivial.

exists (App (Ref n) v'); auto with coc.
red in |- *; red in |- *; intros.
inversion_clear H.
inversion_clear H0.
elim nv with N2; trivial.

elim norm_rec with (subst v' t).
intros t' redt nt.
exists t'; trivial.
apply trans_red_red with (subst v' t); auto with coc.
apply trans_red with (App (Abs T t) v'); auto with coc.

apply red_red1_ord_norm with (App (Abs T t) v'); auto with coc.

exists (App (App a b) v'); auto with coc.
red in |- *; red in |- *; intros.
inversion_clear H.
elim nu with N1; trivial.
elim nv with N2; trivial.

exists (App (Prod T U) v'); auto with coc.
red in |- *; red in |- *; intros.
inversion_clear H.
elim nu with N1; trivial.
elim nv with N2; trivial.

elim norm_rec with T; auto with coc; intros T' redT nT.
elim norm_rec with U; auto with coc; intros U' redU nU.
exists (Prod T' U'); auto with coc.
red in |- *; red in |- *; intros.
inversion_clear H.
elim nT with N1; trivial.
elim nU with N2; trivial.

apply wf_ord_norm; auto with coc.
Defined.

  Definition eqterm : forall u v : term, {u = v} + {u <> v}.
Proof.
decide equality.
decide equality.
apply eq_nat_dec.
Defined.

  Definition is_conv :
   forall u v : term, sn u -> sn v -> {conv u v} + {~ conv u v}.
Proof.
intros u v snu snv.
elim compute_nf with (1 := snu); intros u' redu nu.
elim compute_nf with (1 := snv); intros v' redv nv.
elim eqterm with u' v'; [ intros same_nf | intros diff_nf ].
left.
apply trans_conv_conv with u'; auto with coc.
rewrite same_nf; apply sym_conv; auto with coc.

right; red in |- *; intro; apply diff_nf.
elim church_rosser with u' v'; auto with coc; intros.
rewrite (red_normal u' x); auto with coc.
rewrite (red_normal v' x); auto with coc.

apply trans_conv_conv with v; auto with coc.
apply trans_conv_conv with u; auto with coc.
apply sym_conv; auto with coc.
Defined.


(** Beginning of the file for GV definitions as described in

    Philip Wadler. 2012. Propositions as sessions. In Proceedings of the 17th
    ACM SIGPLAN international conference on Functional programming (ICFP '12).
    ACM, New York, NY, USA, 273-286. DOI=10.1145/2364527.2364568
    http://doi.acm.org/10.1145/2364527.2364568

    which is based on ``Classic GV'' by Simon Gay and Vasco Vasconcelos in

    Simon J. Gay and Vasco T. Vasconcelos. 2010. Linear type theory for
    asynchronous session types. J. Funct. Program. 20, 1 (January 2010),19-50.
    DOI=10.1017/S0956796809990268 http://dx.doi.org/10.1017/S0956796809990268

*)
Require Import Metatheory Coq.Program.Tactics Program.Equality.
Set Implicit Arguments.

(** The notion of kind is borrowed from

    Karl Mazurak, Jianzhou Zhao, and Steve Zdancewic. 2010. Lightweight linear
    types in system f°. In Proceedings of the 5th ACM SIGPLAN workshop on
    Types in language design and implementation (TLDI '10). ACM, New York, NY,
    USA, 77-88. DOI=10.1145/1708016.1708027
    http://doi.acm.org/10.1145/1708016.1708027

    but there is no subsumption rule here. In other words, kinds are just a
    mechanism by which to classify types. The rationale for including kinds is
    to allow a later extension to a System F-pop inspired language.

    In lemmas and theorems, k is used to range over kinds.
*)
Inductive kind : Set :=
  | lin : kind (* linear *)
  | un : kind (* unlimited *).

(** [typ] is ranged over by T, U and V. It differs slightly from the
    definition given in Wadler's paper in the following ways:

      * Session types are defined within this inductive type rather than
        mutually; a technical convenience since Coq mutually inductive
        types can be tricky to manipulate,
      * Choice and branch are binary; this matches the intuition of tensor
        product which is defined as binary and also maps better to the CP
        with and plus constructs which are also binary
*)
Inductive typ : Set :=
(* Session types section *)
  | typ_soutput : typ -> typ -> typ
  | typ_sinput : typ -> typ -> typ
  | typ_schoice : typ -> typ -> typ
  | typ_sbranch : typ -> typ -> typ
  | typ_oend : typ (* output end *)
  | typ_iend : typ (* input end *)
(* Other non-session GV types *)
  | typ_tensor :  typ -> typ -> typ
  | typ_labs : typ -> typ -> typ
  | typ_abs : typ -> typ -> typ
  | typ_unit : typ (* always unlimited *).

(** The notation for sessions has been altered from the standard presentation
    to fit within allowable notations in Coq.
*)
Notation "'!' T '#' S" := (typ_soutput T S) (at level 68,
                                             right associativity) : gv_scope.
Notation "'?' T '#' S" := (typ_sinput T S) (at level 68, right associativity).
Notation "S1 '<+>' S2" := (typ_schoice S1 S2) (at level 68,
                                               right associativity)
                                              : gv_scope.
Notation "S1 <&> S2" := (typ_sbranch S1 S2) (at level 68,
                                             right associativity) : gv_scope.
Notation "T ⊸ U" := (typ_labs T U) (at level 68, right associativity)
                                   : gv_scope.
Notation "T ⟶ U" := (typ_abs T U) (at level 68, right associativity)
                                  : gv_scope.
Notation "T <x> U" := (typ_tensor T U) (at level 68, right associativity)
                                     : gv_scope.
Delimit Scope gv_scope with gv.
Open Scope gv_scope.

(** [ty] as defined above is more general than the types handled by GV; the
    types are considered session types and so could, for example, appear in
    branch or choice constructs (e.g. a regular function type). To prevent
    this, a predicate [is_session] is defined over [typ] constructors to
    restrict where certain constructors may occur.

    S range over session types.
*)
Inductive is_session : typ -> Prop :=
  | is_output : forall (T: typ) S
                       (IS: is_session S),
                  is_session (! T # S)
  | is_input : forall (T: typ) S
                      (IS: is_session S),
                 is_session (? T # S)
  | is_choice : forall S1 S2 (IS1: is_session S1) (IS2: is_session S2),
                  is_session (S1 <+> S2)
  | is_branch : forall S1 S2 (IS1: is_session S1) (IS2: is_session S2),
                  is_session (S1 <&> S2)
  | is_oend : is_session typ_oend
  | is_iend : is_session typ_iend.

Hint Constructors is_session.

(** Well-formed types are types with the correct kind annotations. *)
Inductive wf_typ : typ -> kind -> Prop :=
(* Session types section *)
  | wf_output : forall k T S (WFT: wf_typ T k) (WFS: wf_typ S lin)
                       (IS: is_session S),
                  wf_typ (! T # S) lin
  | wf_input : forall k T S (WFT: wf_typ T k) (WFS: wf_typ S lin)
                      (IS: is_session S),
                 wf_typ (? T # S) lin
  | wf_choice : forall S1 S2 (WFS1: wf_typ S1 lin) (WFS2: wf_typ S2 lin)
                       (IS1: is_session S1) (IS2: is_session S2),
                  wf_typ (S1 <+> S2) lin
  | wf_branch : forall S1 S2 (WFS1: wf_typ S1 lin) (WFS2: wf_typ S2 lin)
                       (IS1: is_session S1) (IS2: is_session S2),
                  wf_typ (S1 <&> S2) lin
  | wf_oend : wf_typ typ_oend lin (* output end *)
  | wf_iend : wf_typ typ_iend lin (* input end *)
(* Other non-session GV types *)
  | wf_tensor : forall kt ku T U (WFT: wf_typ T kt) (WFU: wf_typ U ku),
                  wf_typ (T <x> U) lin
  | wf_labs : forall kt ku T U (WFT: wf_typ T kt) (WFU: wf_typ U ku),
                wf_typ (T ⊸ U) lin
  | wf_abs : forall kt ku T U (WFT: wf_typ T kt) (WFU: wf_typ U ku),
               wf_typ (T ⟶ U) un
  | wf_unit : wf_typ typ_unit un.

Hint Constructors wf_typ.

(** Define a duality relation on session types to specify that two session
    types are dual to each other.

    The computational view of duality cannot be used in the well-typed term
    relation because the proof of duality cannot be inferred for an arbitrary
    session type argument.
*)
Inductive are_dual : typ -> typ -> Prop :=
  | output_dual : forall k T (WFT: wf_typ T k) S S' (DU: are_dual S S'),
                    are_dual (! T # S) (? T # S')
  | input_dual : forall k T (WFT: wf_typ T k) S S' (DU: are_dual S S'),
                   are_dual (? T # S) (! T # S')
  | choice_dual : forall S1 S2 S1' S2'
                         (DU1: are_dual S1 S1') (DU2: are_dual S2 S2'),
                    are_dual (S1 <+> S2) (S1' <&> S2')
  | branch_dual : forall S1 S2 S1' S2'
                         (DU1: are_dual S1 S1') (DU2: are_dual S2 S2'),
                    are_dual (S1 <&> S2) (S1' <+> S2')
  | oend_dual : are_dual typ_oend typ_iend
  | iend_dual : are_dual typ_iend typ_oend.

Hint Constructors are_dual.

(** Only called on a session type. *)
Fixpoint dual_session (T:typ) :=
  match T with
    | ! A # B => ? A # (dual_session B)
    | ? A # B => ! A # (dual_session B)
    | A <+> B => (dual_session A) <&> (dual_session B)
    | A <&> B => (dual_session A) <+> (dual_session B)
    | typ_iend => typ_oend
    | typ_oend => typ_iend
    | _ => T
  end.

(** Define a label type for binary branch and choice. *)
Inductive label : Set :=
  | lb_inr : label
  | lb_inl : label.

Inductive var : Set :=
  | bvar : nat -> var
  | fvar : atom -> var.

Coercion bvar : nat >-> var.
Coercion fvar : atom >-> var.

(** Define the terms of GV. We follow the approach in the UPenn Metatheory
    library, defining free variables as atoms and bound variables as de
    Bruijn indices.

*)
Inductive term : Set :=
  | tm_var : var -> term
  | tm_unit : term
  | tm_weak : var -> term -> term
  | tm_abs : typ -> term -> term
  | tm_iabs : term -> term (* introduction rule for unlimited abstraction. *)
  | tm_eabs : term -> term (* elimination rule for unlimited abstraction. *)
  | tm_app : term -> term -> term
  | tm_pair : term -> term -> term
  | tm_let : typ -> typ -> term -> term -> term
  | tm_send : term -> term -> term
  | tm_recv : term -> term
  | tm_select : label -> term -> term
  | tm_case : term -> term -> term -> term
  | tm_connect : typ -> term -> term -> term
  | tm_end : term -> term.

Coercion tm_var : var >-> term.

Notation "λ! M" := (tm_iabs M) (at level 68, right associativity) : gv_scope.
Notation "λ? M" := (tm_eabs M) (at level 68, right associativity) : gv_scope.

(** In the style of ``Engineering Formal Metatheory'' we define
    substitution of expressions for atoms and opening of expressions with
    bound variables.
*)

(** The following definition of substitution for a free variable assumes the
    term to be substituted is locally closed.
*)
Fixpoint subst (x: atom) (u: term) (t: term) : term :=
  match t with
  | tm_var (fvar y) => if x == y then u else (tm_var y)
  | tm_weak v m => tm_weak v (subst x u m)
  | tm_abs T b => tm_abs T (subst x u b)
  | tm_iabs M => tm_iabs (subst x u M)
  | tm_eabs M => tm_eabs (subst x u M)
  | tm_app m n => tm_app (subst x u m) (subst x u n)
  | tm_pair p q => tm_pair (subst x u p) (subst x u q)
  | tm_let T U m n => tm_let T U (subst x u m) (subst x u n)
  | tm_send m n => tm_send (subst x u m) (subst x u n)
  | tm_recv m => tm_recv (subst x u m)
  | tm_select l m => tm_select l (subst x u m)
  | tm_case m nl nr
    => tm_case (subst x u m) (subst x u nl) (subst x u nr)
  | tm_connect T m n => tm_connect T (subst x u m) (subst x u n)
  | tm_end m => tm_end (subst x u m)
  | _ => t
  end.

Notation "[ x ~> u ] t" := (subst x u t) (at level 68) : gv_scope.

(** Opening a term t is replacing an unbound variable with index k with term
    u. Assume u is locally closed and is only substituted once if it contains
    free variables.
*)
Fixpoint open_rec (k: nat) (u: term) (t: term) :=
  match t with
  | tm_var (bvar n) => if k == n then u else (tm_var n)
  | tm_weak v m => tm_weak v (open_rec k u m)
  | tm_abs T b => tm_abs T (open_rec (S k) u b)
  | tm_iabs M => tm_iabs (open_rec k u M)
  | tm_eabs M => tm_eabs (open_rec k u M)
  | tm_app m n => tm_app (open_rec k u m) (open_rec k u n)
  | tm_pair p q => tm_pair (open_rec k u p) (open_rec k u q)
  | tm_let T U m n
    => tm_let T U (open_rec k u m) (open_rec (S (S k)) u n)
  | tm_send m n => tm_send (open_rec k u m) (open_rec k u n)
  | tm_recv m => tm_recv (open_rec k u m)
  | tm_select l m => tm_select l (open_rec k u m)
  | tm_case m nl nr
    => tm_case (open_rec k u m) (open_rec (S k) u nl) (open_rec (S k) u nr)
  | tm_connect T m n
    => tm_connect T (open_rec (S k) u m) (open_rec (S k) u n)
  | tm_end m => tm_end (open_rec k u m)
  | _ => t
  end.

Notation "{ k ~> u } t" := (open_rec k u t) (at level 68,
                                             right associativity) : gv_scope.

(** Opening a term t is replacing the unbound variable with index 0 with term
    u. Assume u is locally closed and is only substituted once if it contains
    free variables.
*)
Definition open t u := open_rec 0 u t.

Hint Unfold open.

Fixpoint GVFV (t: term) :=
  match t with
  | tm_var (fvar y) => singleton y
  | tm_weak (fvar y) m => singleton y `union` GVFV m
  | tm_weak _ m => GVFV m
  | tm_abs T b => GVFV b
  | tm_iabs m => GVFV m
  | tm_eabs m => GVFV m
  | tm_app m n => GVFV m `union` GVFV n
  | tm_pair p q => GVFV p `union` GVFV q
  | tm_let T U m n => GVFV m `union` GVFV n
  | tm_send m n => GVFV m `union` GVFV n
  | tm_recv m => GVFV m
  | tm_select l m => GVFV m
  | tm_case m nl nr => GVFV m `union` GVFV nl `union` GVFV nr
  | tm_connect T m n => GVFV m `union` GVFV n
  | tm_end m => GVFV m
  | _ => empty
  end.

(** A locally closed term has no unbounded variables. Note also using
    cofinite quantification with binding constructs. *)
Inductive lc : term -> Prop :=
  | lc_var : forall (x:atom), lc (tm_var x)
  | lc_unit : lc tm_unit
  | lc_weak : forall (x:atom) M (MLC: lc M), lc (tm_weak x M)
  | lc_abs : forall (L:atoms) k T M
                    (WFT: wf_typ T k)
                    (CO: forall (x:atom), x `notin` L -> lc (open M x)),
               lc (tm_abs T M)
  | lc_app : forall M N (MLC: lc M) (NLC: lc N), lc (tm_app M N)
  | lc_iabs : forall M (MLC: lc M), lc (λ! M)
  | lc_eabs : forall M (MLC: lc M), lc (λ? M)
  | lc_pair : forall M N (MLC: lc M) (NLC: lc N), lc (tm_pair M N)
  | lc_let : forall (L:atoms) T U M N
                    (WF: wf_typ (T <x> U) lin)
                    (MLC: lc M)
                    (NCO: forall (x y:atom)
                                 (XL: x `notin` L)
                                 (YL: y `notin` L `union` singleton x),
                            lc ({1 ~> x} (open N y))),
               lc (tm_let T U M N)
  | lc_send : forall M N (MLC: lc M) (NLC: lc N), lc (tm_send M N)
  | lc_recv : forall M (MLC: lc M), lc (tm_recv M)
  | lc_select : forall lbl M (LCM: lc M), lc (tm_select lbl M)
  | lc_case : forall (L:atoms) M NL NR (MLC: lc M)
                     (NLCO: forall (x:atom), x `notin` L -> lc (open NL x))
                     (NRCO: forall (x:atom), x `notin` L -> lc (open NR x)),
                lc (tm_case M NL NR)
  | lc_connect : forall (L:atoms) T M N
                        (WFT: wf_typ T lin)
                        (MCO: forall (x:atom), x `notin` L -> lc (open M x))
                        (NCO: forall (x:atom), x `notin` L -> lc (open N x)),
                   lc (tm_connect T M N)
  | lc_end : forall M (MLC: lc M), lc (tm_end M).

Hint Constructors lc.

(** Typing environments are lists of (atom,typ) pairs. *)
Definition tenv := list (atom * typ).

Definition un_env (G : tenv) : Prop :=
  forall x (IN: x `in` dom G),
    exists T, wf_typ T un /\ binds x T G.

(** To get Coq to accept the '~' notation used here, we need to make sure t
    and T are parsed as identifiers.

    Reserved Notation "G |- t ~ T" (at level 68, t ident, T ident).

    Inductive wt_tm : tenv -> term -> forall k, typ k -> Prop :=
      | wt_tm_unid : forall x T, (x ~ inr T) |- x ~ T
    where "G '|-' t ~ T" := (wt_tm G t T) : gv_scope.

    However, I'm going to adopt the ∈ notation below since it will be easier
    to differentiate between the environment notation.
*)
Reserved Notation "Φ ⊢ t ∈ T" (at level 69).

Inductive wt_tm : tenv -> term -> typ -> Prop :=
  | wt_tm_id : forall k T x (WFT: wf_typ T k), x ~ T ⊢ x ∈ T
  | wt_tm_unit : nil ⊢ tm_unit ∈ typ_unit
  | wt_tm_weaken : forall Φ x N k T U
                          (WFT: wf_typ T un) (WFU: wf_typ U k)
                          (UN: uniq (x ~ T ++ Φ))
                          (WT: Φ ⊢ N ∈ U),
                     x ~ T ++ Φ ⊢ (tm_weak x N) ∈ U
  | wt_tm_labs : forall (L: atoms) Φ T U M
                        (WF: wf_typ (T ⊸ U) lin)
                        (UN: uniq Φ)
                        (WT: forall (x:atom),
                               x `notin` L ->
                               x ~ T ++ Φ ⊢ (open M x) ∈ U),
                   Φ ⊢ tm_abs T M ∈ T ⊸ U
  | wt_tm_lapp : forall Φ Ψ T U M N
                        (WF: wf_typ (T ⊸ U) lin)
                        (UN: uniq (Φ ++ Ψ))
                        (WTM: Φ ⊢ M ∈ T ⊸ U) (WTN: Ψ ⊢ N ∈ T),
                   Φ ++ Ψ ⊢ (tm_app M N) ∈ U
  | wt_tm_iabs : forall Φ T U M
                       (WF: wf_typ (T ⟶ U) un)
                       (UN: uniq Φ)
                       (WT: Φ ⊢ M ∈ T ⊸ U) (UL: un_env Φ),
                  Φ ⊢ λ! M ∈ T ⟶ U
  | wt_tm_eabs : forall Φ T U M
                       (WF: wf_typ (T ⊸ U) lin)
                       (UN: uniq Φ)
                       (WT: Φ ⊢ M ∈ T ⟶ U),
                  Φ ⊢ λ? M ∈ T ⊸ U
  | wt_tm_pair : forall Φ Ψ T U M N
                        (WF: wf_typ (T <x> U) lin)
                        (UN: uniq (Φ ++ Ψ))
                        (WTM: Φ ⊢ M ∈ T) (WTN: Ψ ⊢ N ∈ U),
                   Φ ++ Ψ ⊢ (tm_pair M N) ∈ T <x> U
  | wt_tm_let :
      forall (L:atoms) Φ Ψ kv T U V M N
             (WF: wf_typ (T <x> U) lin) (WFV: wf_typ V kv)
             (UN: uniq (Φ ++ Ψ))
             (WTM: Φ ⊢ M ∈ T <x> U)
             (WTN: forall (x y:atom)
                          (XL: x `notin` L)
                          (YL: y `notin` L `union` singleton x),
                     x ~ T ++ y ~ U ++ Ψ ⊢ ({1 ~> x} (open N y)) ∈ V),
        Φ ++ Ψ ⊢ (tm_let T U M N) ∈ V
  | wt_tm_send : forall Φ Ψ M T N S
                        (WF: wf_typ (! T # S) lin)
                        (UN: uniq (Φ ++ Ψ))
                        (WTM: Φ ⊢ M ∈ T) (WTN: Ψ ⊢ N ∈ ! T # S),
                   Φ ++ Ψ ⊢ tm_send M N ∈ S
  | wt_tm_recv : forall Φ M T S
                        (WF: wf_typ (? T # S) lin)
                        (UN: uniq Φ)
                        (WT: Φ ⊢ M ∈ ? T # S),
                   Φ ⊢ tm_recv M ∈ typ_tensor T S
  | wt_tm_l_select : forall Φ M S1 S2 (UN: uniq Φ)
                            (WF: wf_typ (S1 <+> S2) lin)
                            (WT: Φ ⊢ M ∈ (S1 <+> S2)),
                       Φ ⊢ tm_select lb_inl M ∈ S1
  | wt_tm_r_select : forall Φ M S1 S2
                            (UN: uniq Φ)
                            (WF: wf_typ (S1 <+> S2) lin)
                            (WT: Φ ⊢ M ∈ (S1 <+> S2)),
                       Φ ⊢ tm_select lb_inr M ∈ S2
  | wt_tm_case : forall (L:atoms) Φ Ψ M NL NR S1 S2 kt T
                        (UN: uniq (Φ ++ Ψ))
                        (WF: wf_typ (S1 <&> S2) lin)
                        (WFT: wf_typ T kt)
                        (WTM: Φ ⊢ M ∈ (S1 <&> S2))
                        (WTNL: forall (x:atom) (NLH: x `notin` L),
                                 x ~ S1 ++ Ψ ⊢ (open NL x) ∈ T)
                        (WTNR: forall (x:atom) (NL: x `notin` L),
                                 x ~ S2 ++ Ψ ⊢ (open NR x) ∈ T),
                   Φ ++ Ψ ⊢ (tm_case M NL NR) ∈ T
  | wt_tm_connect : forall (L:atoms) Φ Ψ M N S S' kt T
                           (UN: uniq (Φ ++ Ψ))
                           (DU: are_dual S S')
                           (WF: wf_typ T kt)
                           (WTM: forall (x:atom) (NL: x `notin` L),
                                   x ~ S ++ Φ ⊢ (open M x) ∈ typ_oend)
                           (WTN: forall (x:atom) (NL: x `notin` L),
                                   x ~ S' ++ Ψ ⊢ (open N x) ∈ T),
                      Φ ++ Ψ ⊢ (tm_connect S M N) ∈ T
  | wt_tm_end : forall Φ M
                       (UN: uniq Φ)
                       (WT: Φ ⊢ M ∈ typ_iend),
                  Φ ⊢ tm_end M ∈ typ_unit
where "Φ ⊢ t ∈ T" := (wt_tm Φ t T) : gv_scope.

Hint Constructors wt_tm.


(* This software is governed by the CeCILL license under French law and
 * abiding by the rules of distribution of free software.  You can  use,
 * modify and/ or redistribute the software under the terms of the CeCILL
 * license as circulated by CEA, CNRS and INRIA at the following URL
 * "http://www.cecill.info".

 * As a counterpart to the access to the source code and  rights to copy,
 * modify and redistribute granted by the license, users are provided only
 * with a limited warranty  and the software's author,  the holder of the
 * economic rights,  and the successive licensors  have only  limited
 * liability.

 * In this respect, the user's attention is drawn to the risks associated
 * with loading,  using,  modifying and/or developing or reproducing the
 * software by the user in light of its specific status of free software,
 * that may mean  that it is complicated to manipulate,  and  that  also
 * therefore means  that it is reserved for developers  and  experienced
 * professionals having in-depth computer knowledge. Users are therefore
 * encouraged to load and test the software's suitability as regards their
 * requirements in conditions enabling the security of their systems and/or
 * data to be ensured and,  more generally, to use and operate it in the
 * same conditions as regards security.

 * The fact that you are presently reading this means that you have had
 * knowledge of the CeCILL license and that you accept its terms.
 *)

From Scheduler.Model Require Import Monad.
From Scheduler.Model.Interface.Types Require Import TypesModel.

Parameter default_nat : CNat.
Parameter is_default_nat : CNat -> RT CBool.

Definition zero : CNat := 0.

Definition sub (n1 : CNat) (n2 : CNat) : RT CNat :=
  ret (n1-n2).

Definition succ (n : CNat) : RT CNat :=
  ret (S(n)).

Definition pred (n : CNat) : RT CNat :=
  ret (pred n).

Definition eqb (n1 n2 : CNat) : RT CBool :=
  ret (Nat.eqb n1 n2).

(* TODO : refléter les entiers C plutot que les entiers naturels *)


Require Import VST.msl.msl_direct.
Require Import FunctionalExtensionality.
Require Import RamifyCoq.msl_ext.ramify_tactics.
Require Import RamifyCoq.msl_ext.overlapping_direct.
Require Import RamifyCoq.heap_model_direct.SeparationAlgebra.

Definition mapsto (x y: adr) : pred world :=
  fun w => x <> 0 /\
    (forall a, a <> x -> lookup_fpm w a = None) /\
    lookup_fpm w x = Some y.

Lemma join_sub_mapsto: forall w1 w2 x y, join_sub w1 w2 -> (mapsto x y * TT)%pred w1 -> (mapsto x y * TT)%pred w2.
Proof.
  intros. destruct_sepcon H0 h. destruct H as [w3 ?]. try_join h2 w3 m. exists h1, m. split; auto.
Qed.

Lemma mapsto_unique: forall x a b w, ~ (mapsto x a * mapsto x b)%pred w.
Proof.
  repeat intro. destruct_sepcon H h. destruct H0 as [? [? ?]]. destruct H1 as [? [? ?]]. destruct h1 as [f1 m1].
  destruct h2 as [f2 m2]. destruct w as [fw mw]. hnf in *. simpl in *. specialize (H x). rewrite H3 in *. rewrite H5 in *.
  inversion H. inversion H9.
Qed.

Lemma mapsto__precise: forall p, precise (EX  v : adr, mapsto p v).
Proof.
  intros.
  repeat intro.
  destruct H1 as [w3 ?], H2 as [w4 ?]; destruct H as [? [? [? ?]]], H0 as [? [? [? ?]]].
  destruct w1 as [v1 f1]; destruct w2 as [v2 f2]; destruct w3 as [v3 f3]; destruct w4 as [v4 f4]; destruct w as [v f].
  hnf in H1, H2; simpl in *. apply exist_ext. extensionality mm. destruct (eq_dec mm p).
  + subst. specialize (H1 p). specialize (H2 p). rewrite H4 in *. rewrite H6 in *. inversion H1.
    - subst. inversion H2.
      * rewrite H10, H12. auto.
      * subst. rewrite <- H8 in H2. rewrite <- H11 in H2. hnf in H2. inversion H2. subst. inversion H15.
    - subst. rewrite <- H8 in H1. rewrite <- H9 in H1. hnf in H1. inversion H1. subst. inversion H13.
  + specialize (H3 mm n). specialize (H5 mm n). rewrite H3, H5. auto.
Qed.

Lemma mapsto_conflict: forall p1 p2 v1 v2, p1 = p2 -> mapsto p1 v1 * mapsto p2 v2 |-- FF.
Proof.
  intros.
  subst.
  intro w. apply mapsto_unique.
Qed.

Lemma disj_mapsto_: forall p1 p2, p1 <> p2 -> disjointed (EX v1: adr, mapsto p1 v1) (EX v2: adr, mapsto p2 v2).
Proof.
  intros.
  hnf. intros. destruct H2 as [v1 ?]. destruct H3 as [v2 ?].
  generalize H2; intro Hx. generalize H3; intro Hy.
  destruct h12 as [f12 x12] eqn:? . hnf in H2. simpl in H2. destruct H2 as [? [? ?]].
  destruct h23 as [f23 x23] eqn:? . hnf in H3. simpl in H3. destruct H3 as [? [? ?]].
  remember (fun xx : adr => if eq_nat_dec xx p1 then Some v1 else (if eq_nat_dec xx p2 then Some v2 else None)) as f.
  assert (finMap f). {
    exists (p1 :: p2 :: nil). intro z. intros. rewrite Heqf. destruct (eq_nat_dec z p1).
    + subst. exfalso. apply H8. apply in_eq.
    + destruct (eq_nat_dec z p2).
      - subst. exfalso. apply H8. apply in_cons, in_eq.
      - trivial.
  } remember (exist (finMap (B:=adr)) f H8) as ff.
  assert (join h12 h23 ff). {
    rewrite Heqw, Heqw0, Heqff. hnf; simpl. rewrite Heqf. intro z. destruct (eq_nat_dec z p1).
    + rewrite e in *. rewrite H5. generalize (H6 p1 H); intro HS. rewrite HS. constructor.
    + destruct (eq_nat_dec z p2).
      - rewrite e in *. rewrite H7. generalize (H4 p2 n); intro HS. rewrite HS. constructor.
      - specialize (H4 z n). specialize (H6 z n0). rewrite H4, H6. constructor.
  } rewrite <- Heqw0 in *. rewrite <- Heqw in *.
  assert (emp h2). {
    apply join_sub_joins_identity with h23.
    + exists h3; auto.
    + try_join h2 h23 t. exists t; auto.
  } elim_emp_direct.
  split; auto. exists ff; auto.
Qed.

Lemma mapsto_inj: forall p v1 v2, mapsto p v1 && mapsto p v2 |-- !! (v1 = v2).
Proof.
  intros; simpl; intro w; intros. destruct H.
  destruct H as [? [? ?]]. destruct H0 as [? [? ?]]. rewrite H2 in H4.
  inversion H4. subst; auto.
Qed.


(** * Mutable map whose lookup operation provides a default value.*)

(* begin hide *)
Set Implicit Arguments.
Set Contextual Implicit.

From Coq Require Import Morphisms.

From ExtLib Require Import
     Core.RelDec.

From ExtLib.Structures Require
     Maps.

From Paco Require Import paco.

From ITree Require Import
     Basics.HeterogeneousRelations
     ITree
     ITreeFacts
     Eq.Paco2
     Events.State
     Events.StateFacts
     Events.MapDefault.

Import ITree.Basics.Basics.Monads.
Import Structures.Maps.
(* end hide *)

Section MapFacts.

  Variables (K V : Type).
  Context {map : Type}.
  Context {M : Map K V map}.
  Context {MOk: MapOk eq M}.
  Context {Kdec: @RelDec K eq}.
  Context {KdecOk: RelDec_Correct Kdec}.

  (* Should move to extlib *)
  Lemma lookup_add_eq: forall k v s, lookup k (add k v s) = Some v.
  Proof.
    intros.
    rewrite mapsto_lookup; apply mapsto_add_eq.
    Unshelve.
    2: typeclasses eauto.
  Qed.

  (* Should move to extlib *)
  Lemma lookup_add_neq: forall k k' v s, k' <> k -> lookup k (add k' v s) = lookup k s.
  Proof.
    intros.
    generalize (@mapsto_add_neq _ _ _ eq _ _ s k' v k H); clear H; intros H.
    setoid_rewrite <- mapsto_lookup in H.
    destruct (lookup k s) as [v' |] eqn:EQ.
    - specialize (H v').
      apply H; auto.
    - destruct (lookup k (add k' v s)) as [v' |] eqn:EQ'; [| reflexivity].
      specialize (H v').
      symmetry; apply H; auto.
  Qed.

  (* Should move to extlib *)
  Lemma lookup_remove_eq:
    forall k s, lookup k (remove k s) = None.
  Proof.
    intros.
    match goal with
      |- ?x = _ => destruct x eqn:EQ
    end; [| reflexivity].
    rewrite mapsto_lookup in EQ.
    exfalso; eapply mapsto_remove_eq; eauto.
  Qed.

  (* Should move to extlib *)
  Lemma lookup_remove_neq:
    forall k k' s, k <> k' -> lookup k (remove k' s) = lookup k s.
  Proof.
    intros.
    match goal with
      |- ?x = _ => destruct x eqn:EQ
    end.
    - rewrite mapsto_lookup in EQ.
      apply mapsto_remove_neq in EQ; auto.
      symmetry; rewrite mapsto_lookup; eauto.
    -  match goal with
         |- _ = ?x => destruct x eqn:EQ'
       end; auto.
       rewrite mapsto_lookup in EQ'.
       eapply mapsto_remove_neq in EQ'; eauto.
       rewrite <- mapsto_lookup in EQ'.
       rewrite EQ in EQ'; inv EQ'.
       Unshelve.
       all: typeclasses eauto.
  Qed.

  Global Instance eq_map_refl {d} : Reflexive (@eq_map _ _ _ _ d).
  Proof.
    red. intros. unfold eq_map. tauto.
  Qed.

  Global Instance eq_map_sym {d} : Symmetric (@eq_map _ _ _ _ d).
  Proof.
    repeat intro.
    unfold eq_map in H.
    rewrite H.
    reflexivity.
  Qed.

  Global Instance eq_map_trans {d} : Transitive (@eq_map _ _ _ _ d).
  Proof.
    repeat intro.
    unfold eq_map in *.
    rewrite H. rewrite H0. reflexivity.
  Qed.

  Section Relations.
  Context {R1 R2 : Type}.
  Variable RR : R1 -> R2 -> Prop.

  Definition map_default_eq d {E}
    : (stateT map (itree E) R1) -> (stateT map (itree E) R2) -> Prop :=
    fun t1 t2 => forall s1 s2, (@eq_map _ _ _ _ d) s1 s2 -> eutt (prod_rel (@eq_map _ _ _ _ d) RR) (t1 s1) (t2 s2).

  End Relations.

  Lemma eq_map_add:
    forall (d : V) (s1 s2 : map) (k : K) (v : V), (@eq_map _ _ _ _ d) s1 s2 -> (@eq_map _ _ _ _ d) (add k v s1) (add k v s2).
  Proof.
    intros d s1 s2 k v H.
    unfold eq_map in *.
    intros k'.
    destruct (rel_dec_p k k').
    - subst.
      unfold lookup_default in *.
      rewrite 2 lookup_add_eq; reflexivity.
    - unfold lookup_default in *.
      rewrite 2 lookup_add_neq; auto.
  Qed.

  Lemma eq_map_remove:
    forall (d : V) (s1 s2 : map) (k : K), (@eq_map _ _ _ _ d) s1 s2 -> (@eq_map _ _ _ _ d) (remove k s1) (remove k s2).
  Proof.
    intros d s1 s2 k H.
    unfold eq_map in *; intros k'.
    unfold lookup_default.
    destruct (rel_dec_p k k').
    - subst; rewrite 2 lookup_remove_eq; auto.
    - rewrite 2 lookup_remove_neq; auto.
      apply H.
  Qed.

  Lemma handle_map_eq :
    forall d E X (s1 s2 : map) (m : mapE K d X),
      (@eq_map _ _ _ _ d) s1 s2 ->
      eutt (prod_rel (@eq_map _ _ _ _ d) eq) (handle_map m s1) ((handle_map m s2) : itree E (map * X)).
  Proof.
    intros.
    destruct m; cbn; red; apply eqit_Ret; constructor; cbn; auto.
    - apply eq_map_add. assumption.
    - apply eq_map_remove. assumption.
  Qed.

  Global Instance Proper_handle_map {E R}  d :
    Proper (eq ==> map_default_eq eq d) (@handle_map _ _ _ _ E d R).
  Proof.
    repeat intro.
    subst.
    apply handle_map_eq.
    assumption.
  Qed.

  (* This lemma states that the operations provided by [handle_map] respect
     the equivalence on the underlying map interface *)
  Lemma interp_map_id d {E X} (t : itree (mapE K d +' E) X) :
    map_default_eq eq d (interp_map t) (interp_map t).
  Proof.
    unfold map_default_eq, interp_map; intros.
    revert t s1 s2 H.
    ginit.
    pcofix CH.
    intros.
    repeat rewrite unfold_interp_state. unfold _interp_state.
    destruct (observe t).
    - gstep. constructor. constructor; auto.
    - gstep. constructor. gbase. apply CH. assumption.
    - guclo eqit_clo_bind. econstructor.
      unfold pure_state.
      destruct e.
      + cbn. eapply eqit_mon; [ exact (fun x => x) .. | | apply handle_map_eq; assumption ].
        auto. auto. intros.  apply PR.
      + cbn. apply eqit_Vis. intros.  apply eqit_Ret. constructor; auto.
      + intros. destruct u1. destruct u2. cbn.
        destruct H as [H1 H2]; cbn in H1, H2; subst.
        gstep; constructor.
        gbase. apply CH. assumption.
  Qed.

  Global Instance interp_map_proper {R E d} {RR : R -> R -> Prop} :
    Proper ((eutt RR) ==> (@map_default_eq _ _ RR d E)) (@interp_map _ _ _ _ E d R).
  Proof.
    unfold map_default_eq, interp_map.
    repeat intro.
    revert x y H s1 s2 H0.
    einit.
    ecofix CH.
    intros.
    rewrite! unfold_interp_state.
    punfold H0. red in H0.
    revert s1 s2 H1.
    induction H0; intros; subst; simpl; pclearbot.
    - eret.
    - etau.
    - ebind.
      apply pbc_intro_h with (RU := prod_rel (@eq_map _ _ _ _ d) eq).
      { (* SAZ: I must be missing some lemma that should solve this case *)
        unfold case_. unfold Case_sum1, case_sum1.
        destruct e. apply handle_map_eq. assumption.
        unfold pure_state.
        pstep. econstructor. intros. constructor. pfold. econstructor. constructor; auto.
      }
      intros. destruct H as [HH1 ->].
      estep; constructor. ebase.
    - rewrite tau_euttge, unfold_interp_state.
      eauto.
    - rewrite tau_euttge, unfold_interp_state.
      eauto.
  Qed.

End MapFacts.


Require Import SpecDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import AbsAccessor.Spec.
Require Import RVIC2.Spec.

Local Open Scope Z_scope.

Section SpecLow.

  Definition rvic_set_pending_spec0 (rvic: Pointer) (intid: Z64) (adt: RData) : option RData :=
    match rvic, intid with
    | (_rvic_base, _rvic_ofst), VZ64 _intid =>
      when'' _t'1_base, _t'1_ofst == get_rvic_pending_bits_spec (_rvic_base, _rvic_ofst) adt;
      rely is_int _t'1_ofst;
      rely is_int64 _intid;
      when adt == rvic_set_flag_spec (VZ64 _intid) (_t'1_base, _t'1_ofst) adt;
      Some adt
     end
    .

End SpecLow.


(**************************  uc/OS-II  *******************************)
(*************************** OS_CORE.C *******************************)
(**Proof of Internal Fucntion: void OS_EventTaskWait(OS_EVENT* pevent) **)
(**************************** Code:***********************************)
(*
Void ·OS_EventTaskWait·(⌞pevent @ OS_EVENT∗⌟)··{
       ⌞ ⌟;

1       OSTCBCur′→OSTCBEventPtr =ₑ pevent′;ₛ
2       OSRdyTbl′[OSTCBCur′→OSTCBY] =ₑ
                 OSRdyTbl′[OSTCBCur′→OSTCBY] &ₑ (∼OSTCBCur′→OSTCBBitX);ₛ
3       If (OSRdyTbl′[OSTCBCur′→OSTCBY] ==ₑ ′0)
        {
4           OSRdyGrp′ =ₑ OSRdyGrp′ &ₑ (∼OSTCBCur′→OSTCBBitY)
        };ₛ
5       pevent′→OSEventTbl[OSTCBCur′→OSTCBY] =ₑ
               pevent′→OSEventTbl[OSTCBCur′→OSTCBY] |ₑ OSTCBCur′→OSTCBBitX;ₛ
6       pevent′→OSEventGrp =ₑ pevent′→OSEventGrp |ₑ OSTCBCur′→OSTCBBitY;ₛ
7       RETURN
}·.
*)

(* Require Import ucert. *)
Require Import ucos_include.
Require Import OSETWaitPure.
Open Scope code_scope.

Lemma OSEventTaskWait_proof:
    forall tid vl p r ll,
      Some p =
      BuildPreI os_internal OS_EventTaskWait
                  vl ll OS_EventTaskWaitPre tid ->
      Some r =
      BuildRetI os_internal OS_EventTaskWait vl ll OS_EventTaskWaitPost tid ->
      exists t d1 d2 s,
        os_internal OS_EventTaskWait = Some (t, d1, d2, s) /\
        {|OS_spec , GetHPrio, OSLInv, I, r, Afalse|}|- tid {{p}} s {{Afalse}}.
Proof.
  init_spec.
  hoare unfold.

  hoare forward.
  hoare unfold.

  lets Hi3: range_ostcby H.
  destruct Hi3 as [Hi3 Hi2].
  assert (Z.to_nat (Int.unsigned i3) < length v'0)%nat.
  {
    rewrite H8.
    unfold OS_RDY_TBL_SIZE.

    apply z_le_7_imp_n;auto.
    omega.
  }

  lets Hx: array_int8u_nth_lt_len H2 H12.
  Import DeprecatedTactic.
  mytac.
  hoare forward.
  go.
  (* simpl;splits;pauto. *)

  rewrite H8.
  unfold OS_RDY_TBL_SIZE.
  simpl Z.of_nat.
  auto.

(* ** ac:   Locate array_type_vallist_match_imp_rule_type_val_match. *)
  Import symbolic_lemmas.

  eapply array_type_vallist_match_imp_rule_type_val_match.
  rewrite H8.
  unfold OS_RDY_TBL_SIZE.

  apply z_le_7_imp_n;auto.
  omega.
  auto.

  go.
  (* simpl;splits;pauto. *)
  unfold val_inj.
  unfold and.
  rewrite H27.
  auto.

  go.
  (* simpl;splits;pauto. *)
  unfold OS_RDY_TBL_SIZE.
  simpl Z.of_nat.
  auto.
  rewrite H8.
  unfold OS_RDY_TBL_SIZE.
  simpl Z.of_nat.
  auto.
  (*
  Focus 2.
  hoare lift 8%nat pre.
  apply backward_rule1 with Afalse.
  intros.

  sep remember (1::nil)%nat in H2.
  simpl in H2.
  mytac;auto.
  apply pfalse_rule.
   *)
  unfold AOSRdyGrp.
  hoare forward.
  (* simpl;splits;pauto. *)
  go.
  rewrite H27.

  rewrite <- update_nth_val_length_eq.
  rewrite H8.
  unfold OS_RDY_TBL_SIZE.
  simpl Z.of_nat.
  auto.
  rewrite len_lt_update_get_eq.
  rewrite H27.
  simpl.
  rtmatch_solve.
  apply int_lemma1;auto.
  rewrite H8.
  unfold OS_RDY_TBL_SIZE.
  simpl Z.of_nat.
  auto.
  rewrite H27.
  rewrite len_lt_update_get_eq.
  simpl.
(* ** ac:   Locate "$". *)
  Local Open Scope int_scope.
  destruct (Int.eq (x&ᵢInt.not i2) ($ 0));auto.
  rewrite H8.
  unfold OS_RDY_TBL_SIZE.
  simpl Z.of_nat.
  auto.

  eapply forward_rule2.
  hoare forward.

  go.
  (* simpl;splits;pauto. *)
  unfold val_inj.
  unfold and.

  destruct v'1;tryfalse.
  auto.
  intros.
  apply H29.
  apply disj_rule;pure intro.
  clear  H35 H33 H34.

  assert (Z.to_nat (Int.unsigned i3) < length v'4)%nat.
  rewrite H9.
  unfold OS_EVENT_TBL_SIZE.
  apply z_le_7_imp_n;auto.
  omega.
  lets Hx:array_int8u_nth_lt_len H4 H33.
  mytac.
  hoare forward.
  go.
  (* simpl;splits;pauto. *)
  rewrite H9.
  unfold OS_EVENT_TBL_SIZE.
  simpl Z.of_nat.
  auto.
  rewrite H34.
  simpl.
  rtmatch_solve.
  go.
  (* simpl;splits;pauto. *)
  rewrite H34.
  simpl.
  auto.
  go.
  (* simpl;splits;pauto. *)

  eapply eq_int;auto.
  rewrite H9.
  unfold OS_EVENT_TBL_SIZE.
  simpl Z.of_nat.
  auto.

  hoare forward.
  go.
  go.

  hoare forward.
  simpl;auto.
  simpl;auto.
  2:simpl;auto.
  2:auto.
  4:simpl;auto.
  5:auto.
  6:simpl;auto.
  splits;auto.
  eapply nth_val'_imp_nth_val_int;eauto.
  simpl.

  rewrite <- unsigned_to_z_eq.
  rewrite unsigned_to_z_eq.
  rewrite H27.

  simpl.
  auto.
  rewrite unsigned_to_z_eq.
  eapply nth_val'_imp_nth_val_int;eauto.
  splits;auto.
  rewrite <- unsigned_to_z_eq.
  rewrite unsigned_to_z_eq.
  rewrite H34.
  simpl.
  auto.
  split;auto.
  rewrite H27.
  simpl.
  rewrite H27 in H30.
  rewrite len_lt_update_get_eq in H30.
  assert (Int.eq (x &ᵢInt.not i2) ($ 0) =true).
  clear -H30.
  simpl in H30.
  simpl.
  destruct (Int.eq (x &ᵢInt.not i2) ($ 0));tryfalse;auto.

  eapply event_wait_rl_tbl_grp';eauto.
  rewrite H8.
  simpl;auto.
  unfold and.
  unfold val_inj.
  rewrite H27.
  eapply idle_in_rtbl_hold;eauto.

  rtmatch_solve.
  apply int_lemma1;auto.
  split.
  rewrite H27.

  eapply array_type_vallist_match_int8u_update_hold;eauto.
  omega.
  rewrite H27.

  rewrite <- update_nth_val_length_eq.
  auto.
  go.

  rewrite H34.
  eapply event_wait_rl_tbl_grp;eauto.
  simpl;auto.
  apply array_type_vallist_match_hold;auto.
  rewrite H34.
  rtmatch_solve.
  apply int_unsigned_or_prop;auto.
  simpl;splits;auto.
  rtmatch_solve.
  rtmatch_solve.
  apply int_unsigned_or_prop';auto.
  pauto.
  pauto.
  pauto.

  (*------------------------------*)

  assert (Z.to_nat (Int.unsigned i3) < length v'4)%nat.
  rewrite H9.
  unfold OS_EVENT_TBL_SIZE.
  apply z_le_7_imp_n;auto.
  omega.
  lets Hx:array_int8u_nth_lt_len H4 H31.
  mytac.
  hoare forward.
  go.
  rewrite H9.
  unfold OS_EVENT_TBL_SIZE.
  simpl Z.of_nat.
  auto.
  rewrite H32.
  simpl.
  rtmatch_solve.
  go.
  rewrite H32.
  simpl.
  auto.
  go.

  eapply eq_int;auto.
  rewrite H9.
  unfold OS_EVENT_TBL_SIZE.
  simpl Z.of_nat.
  auto.

  hoare forward.
  go.
  go.

  hoare forward.
   simpl;auto.
  simpl;auto.
  2:simpl;auto.
  2:auto.
  4:simpl;auto.
  5:auto.
  6:simpl;auto.
  splits;auto.
  eapply nth_val'_imp_nth_val_int;eauto.
  simpl.

  rewrite <- unsigned_to_z_eq.
  rewrite unsigned_to_z_eq.
  rewrite H27.

  simpl.
  auto.
  rewrite unsigned_to_z_eq.
  eapply nth_val'_imp_nth_val_int;eauto.
  splits;auto.
  rewrite <- unsigned_to_z_eq.
  rewrite unsigned_to_z_eq.
  rewrite H32.
  simpl.
  auto.
  split;auto.
  rewrite H27.
  simpl.
  rewrite H27 in H30.
  rewrite len_lt_update_get_eq in H30.
  assert (Int.eq (x &ᵢInt.not i2) ($ 0) = false).
  clear -H30.
  simpl in H30.
  destruct H30.
  simpl in H.
  destruct (Int.eq (x &ᵢInt.not i2) ($ 0));tryfalse;auto.
  simpl in H.
  destruct (Int.eq (x &ᵢInt.not i2) ($ 0));tryfalse;auto.

  eapply event_wait_rl_tbl_grp'';eauto.
  rewrite H8.
  simpl;auto.
  unfold and.
  unfold val_inj.
  rewrite H27.
  eapply idle_in_rtbl_hold;eauto.

  rtmatch_solve.
  split.
  rewrite H27.

  eapply array_type_vallist_match_int8u_update_hold;eauto.
  omega.
  rewrite H27.

  rewrite <- update_nth_val_length_eq.
  auto.
  go.
  simpl.
  rewrite H32.
  eapply event_wait_rl_tbl_grp;eauto.
  simpl;auto.
  apply array_type_vallist_match_hold;auto.
  rewrite H32.
  rtmatch_solve.
  apply int_unsigned_or_prop;auto.
  simpl;splits;auto.
  rtmatch_solve.
  rtmatch_solve.
  apply int_unsigned_or_prop';auto.
  pauto.
  pauto.
  pauto.

Qed.


Fail Definition my_f_equal {A B : Type} (f : A -> B) (a a' : A) (p : a = a') : f a = f a' :=
  eq_ind _ _ (fun a' => f a = f a') _ _ p.


From iris.algebra Require Export ofe.
From iris Require Import options.

Record solution (F : oFunctor) := Solution {
  solution_car :> ofeT;
  solution_cofe : Cofe solution_car;
  solution_iso :> ofe_iso (oFunctor_apply F solution_car) solution_car;
}.
Existing Instance solution_cofe.

Module solver. Section solver.
Context (F : oFunctor) `{Fcontr : oFunctorContractive F}.
Context `{Fcofe : ∀ (T : ofeT) `{!Cofe T}, Cofe (oFunctor_apply F T)}.
Context `{Finh : Inhabited (oFunctor_apply F unitO)}.
Notation map := (oFunctor_map F).

Fixpoint A' (k : nat) : { C : ofeT & Cofe C } :=
  match k with
  | 0 => existT (P:=Cofe) unitO _
  | S k => existT (P:=Cofe) (@oFunctor_apply F (projT1 (A' k)) (projT2 (A' k))) _
  end.
Notation A k := (projT1 (A' k)).
Local Instance A_cofe k : Cofe (A k) := projT2 (A' k).

Fixpoint f (k : nat) : A k -n> A (S k) :=
  match k with 0 => OfeMor (λ _, inhabitant) | S k => map (g k,f k) end
with g (k : nat) : A (S k) -n> A k :=
  match k with 0 => OfeMor (λ _, ()) | S k => map (f k,g k) end.
Definition f_S k (x : A (S k)) : f (S k) x = map (g k,f k) x := eq_refl.
Definition g_S k (x : A (S (S k))) : g (S k) x = map (f k,g k) x := eq_refl.
Arguments f : simpl never.
Arguments g : simpl never.

Lemma gf {k} (x : A k) : g k (f k x) ≡ x.
Proof using Fcontr.
  induction k as [|k IH]; simpl in *; [by destruct x|].
  rewrite -oFunctor_map_compose -{2}[x]oFunctor_map_id.
  by apply (contractive_proper map).
Qed.
Lemma fg {k} (x : A (S (S k))) : f (S k) (g (S k) x) ≡{k}≡ x.
Proof using Fcontr.
  induction k as [|k IH]; simpl.
  - rewrite f_S g_S -{2}[x]oFunctor_map_id -oFunctor_map_compose.
    apply (contractive_0 map).
  - rewrite f_S g_S -{2}[x]oFunctor_map_id -oFunctor_map_compose.
    by apply (contractive_S map).
Qed.

Record tower := {
  tower_car k :> A k;
  g_tower k : g k (tower_car (S k)) ≡ tower_car k
}.
Instance tower_equiv : Equiv tower := λ X Y, ∀ k, X k ≡ Y k.
Instance tower_dist : Dist tower := λ n X Y, ∀ k, X k ≡{n}≡ Y k.
Definition tower_ofe_mixin : OfeMixin tower.
Proof.
  split.
  - intros X Y; split; [by intros HXY n k; apply equiv_dist|].
    intros HXY k; apply equiv_dist; intros n; apply HXY.
  - intros k; split.
    + by intros X n.
    + by intros X Y ? n.
    + by intros X Y Z ?? n; trans (Y n).
  - intros k X Y HXY n; apply dist_S.
    by rewrite -(g_tower X) (HXY (S n)) g_tower.
Qed.
Definition T : ofeT := OfeT tower tower_ofe_mixin.

Program Definition tower_chain (c : chain T) (k : nat) : chain (A k) :=
  {| chain_car i := c i k |}.
Next Obligation. intros c k n i ?; apply (chain_cauchy c n); lia. Qed.
Program Definition tower_compl : Compl T := λ c,
  {| tower_car n := compl (tower_chain c n) |}.
Next Obligation.
  intros c k; apply equiv_dist=> n.
  by rewrite (conv_compl n (tower_chain c k))
    (conv_compl n (tower_chain c (S k))) /= (g_tower (c _) k).
Qed.
Global Program Instance tower_cofe : Cofe T := { compl := tower_compl }.
Next Obligation.
  intros n c k; rewrite /= (conv_compl n (tower_chain c k)).
  apply (chain_cauchy c); lia.
Qed.

Fixpoint ff {k} (i : nat) : A k -n> A (i + k) :=
  match i with 0 => cid | S i => f (i + k) ◎ ff i end.
Fixpoint gg {k} (i : nat) : A (i + k) -n> A k :=
  match i with 0 => cid | S i => gg i ◎ g (i + k) end.
Lemma ggff {k i} (x : A k) : gg i (ff i x) ≡ x.
Proof using Fcontr. induction i as [|i IH]; simpl; [done|by rewrite (gf (ff i x)) IH]. Qed.
Lemma f_tower k (X : tower) : f (S k) (X (S k)) ≡{k}≡ X (S (S k)).
Proof using Fcontr. intros. by rewrite -(fg (X (S (S k)))) -(g_tower X). Qed.
Lemma ff_tower k i (X : tower) : ff i (X (S k)) ≡{k}≡ X (i + S k).
Proof using Fcontr.
  intros; induction i as [|i IH]; simpl; [done|].
  by rewrite IH Nat.add_succ_r (dist_le _ _ _ _ (f_tower _ X)); last lia.
Qed.
Lemma gg_tower k i (X : tower) : gg i (X (i + k)) ≡ X k.
Proof. by induction i as [|i IH]; simpl; [done|rewrite g_tower IH]. Qed.

Instance tower_car_ne k : NonExpansive (λ X, tower_car X k).
Proof. by intros X Y HX. Qed.
Definition project (k : nat) : T -n> A k := OfeMor (λ X : T, tower_car X k).

Definition coerce {i j} (H : i = j) : A i -n> A j :=
  eq_rect _ (λ i', A i -n> A i') cid _ H.
Lemma coerce_id {i} (H : i = i) (x : A i) : coerce H x = x.
Proof. unfold coerce. by rewrite (proof_irrel H (eq_refl i)). Qed.
Lemma coerce_proper {i j} (x y : A i) (H1 H2 : i = j) :
  x = y → coerce H1 x = coerce H2 y.
Proof. by destruct H1; rewrite !coerce_id. Qed.
Lemma g_coerce {k j} (H : S k = S j) (x : A (S k)) :
  g j (coerce H x) = coerce (Nat.succ_inj _ _ H) (g k x).
Proof. by assert (k = j) by lia; subst; rewrite !coerce_id. Qed.
Lemma coerce_f {k j} (H : S k = S j) (x : A k) :
  coerce H (f k x) = f j (coerce (Nat.succ_inj _ _ H) x).
Proof. by assert (k = j) by lia; subst; rewrite !coerce_id. Qed.
Lemma gg_gg {k i i1 i2 j} : ∀ (H1: k = i + j) (H2: k = i2 + (i1 + j)) (x: A k),
  gg i (coerce H1 x) = gg i1 (gg i2 (coerce H2 x)).
Proof.
  intros ? -> x. assert (i = i2 + i1) as -> by lia. revert j x H1.
  induction i2 as [|i2 IH]; intros j X H1; simplify_eq/=;
    [by rewrite coerce_id|by rewrite g_coerce IH].
Qed.
Lemma ff_ff {k i i1 i2 j} : ∀ (H1: i + k = j) (H2: i1 + (i2 + k) = j) (x: A k),
  coerce H1 (ff i x) = coerce H2 (ff i1 (ff i2 x)).
Proof.
  intros ? <- x. assert (i = i1 + i2) as -> by lia.
  induction i1 as [|i1 IH]; simplify_eq/=;
    [by rewrite coerce_id|by rewrite coerce_f IH].
Qed.

Definition embed_coerce {k} (i : nat) : A k -n> A i :=
  match le_lt_dec i k with
  | left H => gg (k-i) ◎ coerce (eq_sym (Nat.sub_add _ _ H))
  | right H => coerce (Nat.sub_add k i (Nat.lt_le_incl _ _ H)) ◎ ff (i-k)
  end.
Lemma g_embed_coerce {k i} (x : A k) :
  g i (embed_coerce (S i) x) ≡ embed_coerce i x.
Proof using Fcontr.
  unfold embed_coerce; destruct (le_lt_dec (S i) k), (le_lt_dec i k); simpl.
  - symmetry; by erewrite (@gg_gg _ _ 1 (k - S i)); simpl.
  - exfalso; lia.
  - assert (i = k) by lia; subst.
    rewrite (ff_ff _ (eq_refl (1 + (0 + k)))) /= gf.
    by rewrite (gg_gg _ (eq_refl (0 + (0 + k)))).
  - assert (H : 1 + ((i - k) + k) = S i) by lia.
    rewrite (ff_ff _ H) /= -{2}(gf (ff (i - k) x)) g_coerce.
    by erewrite coerce_proper by done.
Qed.
Program Definition embed (k : nat) (x : A k) : T :=
  {| tower_car n := embed_coerce n x |}.
Next Obligation. intros k x i. apply g_embed_coerce. Qed.
Instance: Params (@embed) 1 := {}.
Instance embed_ne k : NonExpansive (embed k).
Proof. by intros n x y Hxy i; rewrite /= Hxy. Qed.
Definition embed' (k : nat) : A k -n> T := OfeMor (embed k).
Lemma embed_f k (x : A k) : embed (S k) (f k x) ≡ embed k x.
Proof.
  rewrite equiv_dist=> n i; rewrite /embed /= /embed_coerce.
  destruct (le_lt_dec i (S k)), (le_lt_dec i k); simpl.
  - assert (H : S k = S (k - i) + (0 + i)) by lia; rewrite (gg_gg _ H) /=.
    by erewrite g_coerce, gf, coerce_proper by done.
  - assert (S k = 0 + (0 + i)) as H by lia.
    rewrite (gg_gg _ H); simplify_eq/=.
    by rewrite (ff_ff _ (eq_refl (1 + (0 + k)))).
  - exfalso; lia.
  - assert (H : (i - S k) + (1 + k) = i) by lia; rewrite (ff_ff _ H) /=.
    by erewrite coerce_proper by done.
Qed.
Lemma embed_tower k (X : T) : embed (S k) (X (S k)) ≡{k}≡ X.
Proof.
  intros i; rewrite /= /embed_coerce.
  destruct (le_lt_dec i (S k)) as [H|H]; simpl.
  - rewrite -(gg_tower i (S k - i) X).
    apply (_ : Proper (_ ==> _) (gg _)); by destruct (eq_sym _).
  - rewrite (ff_tower k (i - S k) X). by destruct (Nat.sub_add _ _ _).
Qed.

Program Definition unfold_chain (X : T) : chain (oFunctor_apply F T) :=
  {| chain_car n := map (project n,embed' n) (X (S n)) |}.
Next Obligation.
  intros X n i Hi.
  assert (∃ k, i = k + n) as [k ?] by (exists (i - n); lia); subst; clear Hi.
  induction k as [|k IH]; simpl; first done.
  rewrite -IH -(dist_le _ _ _ _ (f_tower (k + n) _)); last lia.
  rewrite f_S -oFunctor_map_compose.
  by apply (contractive_ne map); split=> Y /=; rewrite ?g_tower ?embed_f.
Qed.
Definition unfold (X : T) : oFunctor_apply F T := compl (unfold_chain X).
Instance unfold_ne : NonExpansive unfold.
Proof.
  intros n X Y HXY. by rewrite /unfold (conv_compl n (unfold_chain X))
    (conv_compl n (unfold_chain Y)) /= (HXY (S n)).
Qed.

Program Definition fold (X : oFunctor_apply F T) : T :=
  {| tower_car n := g n (map (embed' n,project n) X) |}.
Next Obligation.
  intros X k. apply (_ : Proper ((≡) ==> (≡)) (g k)).
  rewrite g_S -oFunctor_map_compose.
  apply (contractive_proper map); split=> Y; [apply embed_f|apply g_tower].
Qed.
Instance fold_ne : NonExpansive fold.
Proof. by intros n X Y HXY k; rewrite /fold /= HXY. Qed.

Theorem result : solution F.
Proof using Type*.
  refine (Solution F T _ (OfeIso (OfeMor fold) (OfeMor unfold) _ _)).
  - move=> X /=. rewrite equiv_dist=> n k; rewrite /unfold /fold /=.
    rewrite -g_tower -(gg_tower _ n); apply (_ : Proper (_ ==> _) (g _)).
    trans (map (ff n, gg n) (X (S (n + k)))).
    { rewrite /unfold (conv_compl n (unfold_chain X)).
      rewrite -(chain_cauchy (unfold_chain X) n (S (n + k))) /=; last lia.
      rewrite -(dist_le _ _ _ _ (f_tower (n + k) _)); last lia.
      rewrite f_S -!oFunctor_map_compose; apply (contractive_ne map); split=> Y.
      + rewrite /embed' /= /embed_coerce.
        destruct (le_lt_dec _ _); simpl; [exfalso; lia|].
        by rewrite (ff_ff _ (eq_refl (S n + (0 + k)))) /= gf.
      + rewrite /embed' /= /embed_coerce.
        destruct (le_lt_dec _ _); simpl; [|exfalso; lia].
        by rewrite (gg_gg _ (eq_refl (0 + (S n + k)))) /= gf. }
    assert (∀ i k (x : A (S i + k)) (H : S i + k = i + S k),
      map (ff i, gg i) x ≡ gg i (coerce H x)) as map_ff_gg.
    { intros i; induction i as [|i IH]; intros k' x H; simpl.
      { by rewrite coerce_id oFunctor_map_id. }
      rewrite oFunctor_map_compose g_coerce; apply IH. }
    assert (H: S n + k = n + S k) by lia.
    rewrite (map_ff_gg _ _ _ H).
    apply (_ : Proper (_ ==> _) (gg _)); by destruct H.
  - intros X; rewrite equiv_dist=> n /=.
    rewrite /unfold /= (conv_compl' n (unfold_chain (fold X))) /=.
    rewrite g_S -!oFunctor_map_compose -{2}[X]oFunctor_map_id.
    apply (contractive_ne map); split => Y /=.
    + rewrite f_tower. apply dist_S. by rewrite embed_tower.
    + etrans; [apply embed_ne, equiv_dist, g_tower|apply embed_tower].
Qed.
End solver. End solver.


(****************************************************************************)
(* Copyright 2021 The Project Oak Authors                                   *)
(*                                                                          *)
(* Licensed under the Apache License, Version 2.0 (the "License")           *)
(* you may not use this file except in compliance with the License.         *)
(* You may obtain a copy of the License at                                  *)
(*                                                                          *)
(*     http://www.apache.org/licenses/LICENSE-2.0                           *)
(*                                                                          *)
(* Unless required by applicable law or agreed to in writing, software      *)
(* distributed under the License is distributed on an "AS IS" BASIS,        *)
(* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. *)
(* See the License for the specific language governing permissions and      *)
(* limitations under the License.                                           *)
(****************************************************************************)

Require Import Coq.NArith.NArith.

Lemma apply_if {A B} (f : A -> B) (b : bool) x y : f (if b then x else y) = if b then f x else f y.
Proof. destruct b; reflexivity. Qed.

Lemma fst_if {A B} (b : bool) (x y : A * B) : fst (if b then x else y) = if b then fst x else fst y.
Proof. apply apply_if. Qed.
Lemma snd_if {A B} (b : bool) (x y : A * B) : snd (if b then x else y) = if b then snd x else snd y.
Proof. apply apply_if. Qed.
Hint Rewrite @fst_if @snd_if using solve [eauto] : tuple_if.

Lemma tup_if {A B} (b : bool) (x y: A) (z w: B) : (if b then x else y, if b then z else w) = if b then (x,z) else (y, w).
Proof. destruct b; reflexivity. Qed.
Hint Rewrite @tup_if using solve [eauto] : tuple_if.

Lemma apply_if_ext_1 {A B C} (f : A -> B -> C) (b : bool) x y z : f (if b then x else y) z = if b then f x z else f y z.
Proof. destruct b; reflexivity. Qed.

Lemma if_true_rew {A} (x: bool) (z: A) P Q: (x = true -> P = Q) ->
    (if x then P else z) = (if x then Q else z).
Proof. intros; destruct x; [ apply H | ]; reflexivity. Qed.

Lemma to_nat_if (b: bool) x y : N.to_nat (if b then x else y) = if b then (N.to_nat x) else (N.to_nat y).
Proof. now destruct b. Qed.
Hint Rewrite to_nat_if : Nnat.


From Coq Require Import List.
From MetaCoq.Template Require Import All.

Import ListNotations.
Import MCMonadNotation.
Open Scope bs_scope.
Definition qlist := Eval compute in match <% list %> with
    | tInd ind _ => ind.(inductive_mind)
    | _ => (MPfile nil, ""%bs)
    end.

Definition refresh_sort t :=
  match t with
  | tSort s =>
      match s with
      | Universe.lProp => tSort Universe.lProp
      | Universe.lSProp => tSort Universe.lSProp
      | Universe.lType _ => tSort Universes.fresh_universe
      end
  | _ => t
  end.

Definition refresh_arity s :=
  let (ctx, concl) := decompose_prod_assum [] s in
  it_mkProd_or_LetIn ctx (refresh_sort concl).

  Definition mind_body_to_entry :=
  fun decl : mutual_inductive_body =>
  {|
  mind_entry_record := None;
  mind_entry_finite := Finite;
  mind_entry_params :=
      match hd_error (ind_bodies decl) with
      | Some i0 =>
          List.rev
          (let typ := decompose_prod (ind_type i0) in
              let (a, b) := typ in
              (fun p : list aname × list term =>
              let (a0, b0) := p in
              (fun (names : list aname) (types : list term) (_ : term) =>
              let names0 := firstn (ind_npars decl) names in
              let types0 := firstn (ind_npars decl) types in
              map (fun '(x, ty) => vass x ty) (combine names0 types0)) a0 b0)
              a b)
      | None => []
      end;
  mind_entry_inds :=
      map
      (fun X : one_inductive_body =>
          match X with
          | {|
              ind_name := ind_name;
              ind_indices := ind_indices;
              ind_sort := ind_sort;
              ind_type := ind_type;
              ind_kelim := ind_kelim;
              ind_ctors := ind_ctors;
              ind_projs := ind_projs;
              ind_relevance := ind_relevance
          |} =>
              {|
              mind_entry_typename := ind_name;
              mind_entry_arity := refresh_arity (remove_arity (ind_npars decl) ind_type);
              mind_entry_consnames :=
                  map (fun x : constructor_body => cstr_name x) ind_ctors;
              mind_entry_lc :=
                  map
                  (fun x : constructor_body =>
                      remove_arity (ind_npars decl) (cstr_type x)) ind_ctors
              |}
          end) (ind_bodies decl);
  mind_entry_universes := universes_entry_of_decl (ind_universes decl);
  mind_entry_template := false;
  mind_entry_variance := option_map (map Some) (ind_variance decl);
  mind_entry_private := None
  |}.

Unset MetaCoq Strict Unquote Universe Mode.
MetaCoq Run (tmQuoteInductive qlist >>= fun mib =>
  let entry := mind_body_to_entry mib in
  entry <- tmEval all entry;;
  tmPrint entry ;;
  tmMkInductive true entry).