(* begin hide *)
(**********************************************************************)
(* Equations                                                          *)
(* Copyright (c) 2009-2021 Matthieu Sozeau <matthieu.sozeau@inria.fr> *)
(**********************************************************************)
(* This file is distributed under the terms of the                    *)
(* GNU Lesser General Public License Version 2.1                      *)
(**********************************************************************)
(* end hide *)
(** * Definitional interpreter for STLC extended with references

  This is a port of the first part of "Intrinsically-Typed Definitional
  Interpreters for Imperative Languages", Poulsen, Rouvoet, Tolmach,
  Krebbers and Visser. POPL'18.

  It uses well-typed and well-scoped syntax and a monad indexed over an
  indexed set of stores to define an interpreter for an imperative
  programming language.

  This showcases the use of dependent pattern-matching and
  pattern-matching lambdas in Equations. We implement a variant where
  store extension is resolved using type class resolution as well as the
  dependent-passing style version. *)

Require Import Program.Basics Program.Tactics.
Require Import Coq.Vectors.VectorDef.
Require Import List.
Import ListNotations.
Require Import Utf8.
From Equations Require Import Equations.

Set Warnings "-notation-overridden".
(** The Σ notation of equations clashes with the Σ's used below,
    so we redefine the Σ notation using ∃ instead.
 *)

Notation "'∃' x .. y , P" := (sigma (fun x => .. (sigma (fun y => P)) ..))
  (at level 200, x binder, y binder, right associativity,
  format "'[  ' '[  ' ∃  x  ..  y ']' ,  '/' P ']'") : type_scope.

Notation "( x , .. , y , z )" :=
  (@sigmaI _ _ x .. (@sigmaI _ _ y z) ..)
      (right associativity, at level 0,
       format "( x ,  .. ,  y ,  z )") : equations_scope.

Notation " x .1 " := (pr1 x) (at level 3, format "x .1") : equations_scope.
Notation " x .2 " := (pr2 x) (at level 3, format "x .2") : equations_scope.

Local Open Scope equations_scope.

Set Equations Transparent.

(** [t] is just [Vector.t] here. *)
Derive Signature NoConfusion NoConfusionHom for t.

(** Types include unit, bool, function types and references *)
Inductive Ty : Set :=
| unit : Ty
| bool : Ty
| arrow (t u : Ty) : Ty
| ref : Ty -> Ty.

Derive NoConfusion for Ty.

Infix "⇒" := arrow (at level 80).

Definition Ctx := list Ty.

Reserved Notation " x ∈ s " (at level 70, s at level 10).

#[universes(template)]
Inductive In {A} (x : A) : list A -> Type :=
| here {xs} : x ∈ (x :: xs)
| there {y xs} : x ∈ xs -> x ∈ (y :: xs)
where " x ∈ s " := (In x s).
Derive Signature NoConfusion for In.

Arguments here {A x xs}.
Arguments there {A x y xs} _.

Inductive Expr : Ctx -> Ty -> Set :=
| tt {Γ} : Expr Γ unit
| true {Γ} : Expr Γ bool
| false {Γ} : Expr Γ bool
| ite {Γ t} : Expr Γ bool -> Expr Γ t -> Expr Γ t -> Expr Γ t
| var {Γ} {t} : In t Γ -> Expr Γ t
| abs {Γ} {t u} : Expr (t :: Γ) u -> Expr Γ (t ⇒ u)
| app {Γ} {t u} : Expr Γ (t ⇒ u) -> Expr Γ t -> Expr Γ u
| new {Γ t} : Expr Γ t -> Expr Γ (ref t)
| deref {Γ t} : Expr Γ (ref t) -> Expr Γ t
| assign {Γ t} : Expr Γ (ref t) -> Expr Γ t -> Expr Γ unit.

(** We derive both [NoConfusion] and [NoConfusionHom] principles here, the later
    allows to simplify pattern-matching problems on [Expr] which would otherwise
    require K. It relies on an inversion analysis of every constructor, showing
    that the context and type indexes in the conclusions of every constructor
    are forced arguments. *)
Derive Signature NoConfusion NoConfusionHom for Expr.

#[universes(template)]
Inductive All {A} (P : A -> Type) : list A -> Type :=
| all_nil : All P []
| all_cons {x xs} : P x -> All P xs -> All P (x :: xs).
Arguments all_nil {A} {P}.
Arguments all_cons {A P x xs} _ _.
Derive Signature NoConfusion NoConfusionHom for All.

Section MapAll.
  Context {A} {P Q : A -> Type} (f : forall x, P x -> Q x).

  Equations map_all {l : list A} : All P l -> All Q l :=
   | all_nil := all_nil
   | all_cons p ps := all_cons (f _ p) (map_all ps).

  Equations map_all_in {l : list A} (f : forall x, x ∈ l -> P x -> Q x) : All P l -> All Q l :=
    | f, all_nil := all_nil
    | f,  all_cons p ps := all_cons (f _ here p) (map_all_in (fun x inl => f x (there inl)) ps).
End MapAll.

Definition StoreTy := list Ty.

Inductive Val : Ty -> StoreTy -> Set :=
| val_unit {Σ} : Val unit Σ
| val_true {Σ} : Val bool Σ
| val_false {Σ} : Val bool Σ
| val_closure {Σ Γ t u} : Expr (t :: Γ) u -> All (fun t => Val t Σ) Γ -> Val (t ⇒ u) Σ
| val_loc {Σ t} : t ∈ Σ -> Val (ref t) Σ.

Derive Signature NoConfusion NoConfusionHom for Val.

Definition Env (Γ : Ctx) (Σ : StoreTy) : Set := All (fun t => Val t Σ) Γ.

Definition Store (Σ : StoreTy) := All (fun t => Val t Σ) Σ.

Equations lookup : forall {A P xs} {x : A}, All P xs -> x ∈ xs -> P x :=
  lookup (all_cons p _) here := p;
  lookup (all_cons _ ps) (there ins) := lookup ps ins.

Equations update : forall {A P xs} {x : A}, All P xs -> x ∈ xs -> P x -> All P xs :=
  update (all_cons p ps) here        p' := all_cons p' ps;
  update (all_cons p ps) (there ins) p' := all_cons p (update ps ins p').

Equations lookup_store {Σ t} : t ∈ Σ -> Store Σ -> Val t Σ :=
  lookup_store l σ := lookup σ l.

Equations update_store {Σ t} : t ∈ Σ -> Val t Σ -> Store Σ -> Store Σ :=
  update_store l v σ := update σ l v.

Definition store_incl (Σ Σ' : StoreTy) := sigma (fun Σ'' => Σ' = Σ'' ++ Σ).
Infix "⊑" := store_incl (at level 10).

Equations app_assoc {A} (x y z : list A) : x ++ y ++ z = (x ++ y) ++ z :=
  app_assoc nil y z := eq_refl;
  app_assoc (cons x xs) y z := f_equal (cons x) (app_assoc xs y z).

Section StoreIncl.
  Equations pres_in {Σ Σ'} (incl : Σ ⊑ Σ') t (p : t ∈ Σ) : t ∈ Σ' :=
    pres_in (Σ'', eq_refl) t p := aux Σ''
       where aux Σ'' : t ∈ (Σ'' ++ Σ) :=
       aux nil := p;
       aux (cons ty tys) := there (aux tys).

  Equations refl_incl {Σ} : Σ ⊑ Σ := refl_incl := ([], eq_refl).

  Equations trans_incl {Σ Σ' Σ''} (incl : Σ ⊑ Σ') (incl' : Σ' ⊑ Σ'') : Σ ⊑ Σ'' :=
    trans_incl (p, eq_refl) (q, eq_refl) := (q ++ p, app_assoc _ _ _).

  Equations store_ext_incl {Σ t} : Σ ⊑ (t :: Σ) :=
    store_ext_incl := ([t], eq_refl).

  Context {Σ Σ'} (incl : Σ ⊑ Σ').

  Equations weaken_val {t} (v : Val t Σ) : Val t Σ' := {
   weaken_val (@val_unit ?(Σ)) := val_unit;
   weaken_val val_true := val_true;
   weaken_val val_false := val_false;
   weaken_val (val_closure b e) := val_closure b (weaken_vals e);
   weaken_val (val_loc H) := val_loc (pres_in incl _ H) }
  where weaken_vals {l} (a : All (fun t => Val t Σ) l) : All (fun t => Val t Σ') l :=
  weaken_vals all_nil := all_nil;
  weaken_vals (all_cons p ps) := all_cons (weaken_val p) (weaken_vals ps).

  Equations weakenv_vals {l} a : @weaken_vals l a = map_all (fun t v => weaken_val v) a :=
    weakenv_vals all_nil := eq_refl;
    weakenv_vals (all_cons p ps) := f_equal (all_cons (weaken_val p)) (weakenv_vals ps).

  Definition weaken_env {Γ} (v : Env Γ Σ) : Env Γ Σ' := map_all (@weaken_val) v.

End StoreIncl.

Infix "⊚" := trans_incl (at level 10).

Equations M : forall (Γ : Ctx) (P : StoreTy -> Type) (Σ : StoreTy), Type :=
  M Γ P Σ := forall (E : Env Γ Σ) (μ : Store Σ), option (∃ Σ' (μ' : Store Σ') (_ : P Σ'), Σ ⊑ Σ').

Equations bind {Σ Γ} {P Q : StoreTy -> Type} (f : M Γ P Σ) (g : ∀ {Σ'}, P Σ' -> M Γ Q Σ') : M Γ Q Σ :=
  bind f g E μ with f E μ :=
     | None := None
     | Some (Σ', μ', x, ext) with g _ x (weaken_env ext E) μ' :=
          | None := None;
          | Some (_, μ'', y, ext') := Some (_, μ'', y, ext ⊚ ext').

Infix ">>=" := bind (at level 20, left associativity).

Definition transp_op {Γ Σ P} (x : Store Σ -> P Σ) : M Γ P Σ :=
  fun E μ => Some (Σ, μ, x μ, refl_incl).

Equations ret : ∀ {Γ Σ P}, P Σ → M Γ P Σ :=
  ret (Σ:=Σ) a E μ := Some (Σ, μ, a, refl_incl).

Equations getEnv : ∀ {Γ Σ}, M Γ (Env Γ) Σ :=
  getEnv (Σ:=Σ) E μ := Some (Σ, μ, E, refl_incl).

Equations usingEnv {Γ Γ' Σ P} (E : Env Γ Σ) (m : M Γ P Σ) : M Γ' P Σ :=
  usingEnv E m E' μ := m E μ.

Equations timeout : ∀ {Γ Σ P}, M Γ P Σ :=
  timeout _ _ := None.

Section StoreOps.
  Context {Σ : StoreTy} {Γ : Ctx} {t : Ty}.

  Equations storeM (v : Val t Σ) : M Γ (Val (ref t)) Σ :=
    storeM v E μ :=
      let v : Val t (t :: Σ) := weaken_val store_ext_incl v in
      let μ' := map_all (fun t' => weaken_val store_ext_incl) μ in
      Some (t :: Σ, all_cons v μ', val_loc here, store_ext_incl).

  Equations derefM (l : t ∈ Σ) : M Γ (Val t) Σ :=
    derefM l := transp_op (lookup_store l).

  Equations updateM (l : t ∈ Σ) (v : Val t Σ) : M Γ (Val unit) Σ :=
    updateM l v E μ := Some (Σ, update_store l v μ, val_unit, refl_incl).
End StoreOps.

Reserved Notation "P ⊛ Q" (at level 10).

Inductive storepred_prod (P Q : StoreTy -> Type) : StoreTy -> Type :=
  | storepred_pair {Σ} : P Σ -> Q Σ -> (P ⊛ Q) Σ
where "P ⊛ Q" := (storepred_prod P Q).
Arguments storepred_pair {P Q Σ}.

Class Weakenable (P : StoreTy -> Type) : Type :=
  weaken : forall {Σ Σ'}, Σ ⊑ Σ' -> P Σ -> P Σ'.

#[local] Instance val_weaken {t} : Weakenable (Val t) := fun Σ Σ' incl => weaken_val incl.
#[local] Instance env_weaken {Γ} : Weakenable (Env Γ) := fun Σ Σ' incl => weaken_env incl.
#[local] Instance loc_weaken (t : Ty) : Weakenable (In t) := fun Σ Σ' incl => pres_in incl t.

Class IsIncludedOnce (Σ Σ' : StoreTy) : Type := is_included_once : Σ ⊑ Σ'.
#[local] Hint Mode IsIncludedOnce + + : typeclass_instances.

#[local] Instance IsIncludedOnce_ext {T} Σ : IsIncludedOnce Σ (T :: Σ) := store_ext_incl.

Class IsIncluded (Σ Σ' : StoreTy) : Type := is_included : Σ ⊑ Σ'.
#[local] Hint Mode IsIncluded + + : typeclass_instances.

#[local] Instance IsIncluded_refl Σ : IsIncluded Σ Σ := refl_incl.
#[local] Instance IsIncluded_trans Σ Σ' Σ'' : IsIncludedOnce Σ Σ' -> IsIncluded Σ' Σ'' -> IsIncluded Σ Σ'' :=
  fun H H' => trans_incl H H'.

Equations wk {Σ Σ' P} {W : Weakenable P} (p : P Σ) {incl : IsIncluded Σ Σ'} : P Σ' :=
  wk p := weaken incl p.

Equations bind_ext {Σ Γ} {P Q : StoreTy -> Type} (f : M Γ P Σ) (g : ∀ {Σ'} `{IsIncluded Σ Σ'}, P Σ' -> M Γ Q Σ') : M Γ Q Σ :=
  bind_ext f g E μ with f E μ :=
    { | None := None;
      | Some (Σ', μ', x, ext) with g _ ext x (weaken_env ext E) μ' :=
          { | None := None;
            | Some (_, μ'', y, ext') := Some (_, μ'', y, ext ⊚ ext') } }.

Infix ">>='" := bind_ext (at level 20, left associativity).

Equations eval_ext (n : nat) {Γ Σ t} (e : Expr Γ t) : M Γ (Val t) Σ :=
  | 0, _                := timeout
  | S k, tt           := ret val_unit
  | S k, true         := ret val_true
  | S k, false        := ret val_false
  | S k, ite b tr fa    := eval_ext k b >>=' λ{ | _ | ext | val_true => eval_ext k tr;
                                                      | _ | ext | val_false => eval_ext k fa }

  | S k, var x        := getEnv >>=' fun {Σ ext} E => ret (lookup E x)
  | S k, abs x        := getEnv >>=' fun {Σ ext} E => ret (val_closure x E)
  | S k, @app Γ A B e1 e2 :=
      eval_ext k e1 >>=' λ{ | _ | ext | val_closure e' E =>
      eval_ext k e2 >>=' fun {Σ' ext'} v => usingEnv (all_cons v (wk (P:=Env _) E)) (eval_ext k e')}
  | S k, new e      := eval_ext k e >>=' fun {Σ ext} v => storeM v
  | S k, deref l    := eval_ext k l >>=' λ{ | _ | ext | val_loc l' => derefM l' }
  | S k, assign l e := eval_ext k l >>=' λ{ | _ | ext | val_loc l' =>
                                eval_ext k e >>=' λ{ | _ | ext' | v => updateM (wk l') (wk v) }}.

Equations strength {Σ Γ} {P Q : StoreTy -> Type} {w : Weakenable Q} (m : M Γ P Σ) (q : Q Σ) : M Γ (P ⊛ Q) Σ :=
  strength m q E μ with m E μ => {
    | None => None
    | Some (Σ', μ', p, ext) => Some (Σ', μ', storepred_pair p (weaken ext q), ext) }.

Infix "^" := strength.

(* Issue: improve pattern matching lambda to have implicit arguments implicit.
   Hard because Coq does not keep the implicit status of bind's [g] argument. *)

Equations eval (n : nat) {Γ Σ t} (e : Expr Γ t) : M Γ (Val t) Σ :=
  eval 0 _                := timeout;
  eval (S k) tt           := ret val_unit;
  eval (S k) true         := ret val_true;
  eval (S k) false        := ret val_false;
  eval (S k) (ite b tr fa)  := eval k b >>= λ{ | _ | val_true => eval k tr;
                                             | _ | val_false => eval k fa };

  eval (S k) (var x)      := getEnv >>= fun Σ E => ret (lookup E x);
  eval (S k) (abs x)      := getEnv >>= fun Σ E => ret (val_closure x E);
  eval (S k) (app e1 e2) :=
      eval k e1 >>= λ{ | _ | val_closure e' E =>
                             (eval k e2 ^ E) >>= fun Σ' '(storepred_pair v E) => usingEnv (all_cons v E) (eval k e')};
  eval (S k) (new e)      := eval k e >>= fun Σ v => storeM v;
  eval (S k) (deref l)    := eval k l >>= λ{ | _ | val_loc l' => derefM l' };
  eval (S k) (assign l e) := eval k l >>= λ{ | _ | val_loc l' =>
                             (eval k e ^ l') >>= λ{ | _ | storepred_pair v l'' => updateM l'' v }}.

Definition idu : Expr [] (unit ⇒ unit) :=
  abs (var here).

Definition idapp : Expr [] unit := app idu tt.

(** All definitions are axiom-free (and actually not even dependent on a provable UIP instance), so
 everything computes. *)
Eval vm_compute in eval 100 idapp all_nil all_nil.

Definition neg : Expr [] (bool ⇒ bool) :=
  abs (ite (var here) false true).

Definition letref {t u} (v : Expr [] t) (b : Expr [ref t] u) : Expr [] u :=
  app (abs b) (new v).
Obligation Tactic := idtac.

Equations in_app_weaken {Σ Σ' Σ'' : StoreTy} {t} (p : t ∈ (Σ ++ Σ'')) : t ∈ (Σ ++ Σ' ++ Σ'') by struct Σ :=
  in_app_weaken (Σ:=nil) p := pres_in (Σ', eq_refl) t p;
  in_app_weaken (Σ:=cons _ tys) here := here;
  in_app_weaken (Σ:=cons _ tys) (there p) := there (in_app_weaken p).

Equations pres_in_prefix {Σ Σ' Σ''} (incl : Σ' ⊑ Σ'') {t} (p : t ∈ (Σ ++ Σ')) : t ∈ (Σ ++ Σ'') :=
  pres_in_prefix (Σ'', eq_refl) p := in_app_weaken p.

(** [Equations?] enters refinement mode, which can be used to solve the case of variables in proof mode. *)
Equations? weaken_expr {Γ Γ' t u} (e1 : Expr (Γ ++ Γ') t) : Expr (Γ ++ u :: Γ') t :=
  weaken_expr tt              := tt;
  weaken_expr true            := true;
  weaken_expr false           := false;
  weaken_expr (ite b tr fa)   := ite (weaken_expr b) (weaken_expr tr) (weaken_expr fa);
  weaken_expr (var (t:=ty) x) := var _;
  weaken_expr (abs (t:=t) x)  := abs (weaken_expr (Γ := t :: Γ) x);
  weaken_expr (app e1 e2)     := app (weaken_expr e1) (weaken_expr e2);
  weaken_expr (new e)         := new (weaken_expr e);
  weaken_expr (deref l)       := deref (weaken_expr l);
  weaken_expr (assign l e)    := assign (weaken_expr l) (weaken_expr e).
Proof.
  clear weaken_expr. apply (pres_in_prefix (Σ' := Γ') ([u], eq_refl) x).
Defined.

Definition seq {Γ u} (e1 : Expr Γ unit) (e2 : Expr Γ u) : Expr Γ u :=
  app (abs (weaken_expr (Γ := []) e2)) e1.

(* let x = ref true in
   x := false; !x *)

Definition letupdate : Expr [] bool :=
  letref true (seq (assign (var here) false) (deref (var here))).

Eval vm_compute in eval 100 letupdate all_nil all_nil.
(** [[
   = Some ([bool], all_cons val_false all_nil, val_false, [bool], eq_refl)
   : option (∃ (Σ' : StoreTy) (_ : Store Σ') (_ : Val bool Σ'), [] ⊑ Σ')
   ]]
*)


(**
CoLoR, a Coq library on rewriting and termination.
See the COPYRIGHTS and LICENSE files.

- Adam Koprowski, 2006-04-27

The beta-reduction relation of simply typed lambda-calculus
is introduced in this file.
*)

Set Implicit Arguments.

From CoLoR Require Import RelExtras ListExtras TermsRed TermsConv LogicUtil.
From Coq Require Import Setoid Lia.

Module TermsBeta (Sig : TermsSig.Signature).

  Module Export TR := TermsRed.TermsRed Sig.

  Definition beta_subst : forall M (Mapp: isApp M)
    (MLabs: isAbs (appBodyL Mapp)),
    correct_subst (absBody MLabs) {x/(lift (appBodyR Mapp) 1)}.

  Proof.
    intros M Mapp MLabs.
    apply one_var_subst_correct.
    rewrite lift_type.
    rewrite absBody_env.
    unfold decl, VarD; simpl.
    intros A' eqT.
    inversion eqT.
    destruct M as [EM PtM TM TypM].
    destruct TypM; try contr.
    rewrite (@abs_type (appBodyL Mapp) MLabs A B); trivial.
    rewrite lift_env.
    rewrite absBody_env.
    unfold liftedEnv, finalSeg; simpl.
    rewrite initialSeg_full; try solve [auto with datatypes | lia].
    unfold decl; apply env_comp_cons.
    rewrite appBodyL_env.
    rewrite appBodyR_env.
    apply env_comp_refl.
    auto.
  Defined.

  Lemma beta_env : forall M (Mapp: isApp M) (MLabs: isAbs (appBodyL Mapp)),
    env (subst (beta_subst M Mapp MLabs)) = None :: env M.

  Proof.
    intros.
    rewrite subst_env; simpl.
    unfold subst_ran; simpl.
    rewrite lift_env; simpl.
    unfold liftedEnv; simpl.
    rewrite absBody_env; simpl.
    rewrite appBodyL_env; simpl.
    rewrite finalSeg_full; simpl.
    rewrite appBodyR_env; simpl.
    rewrite env_sub_empty.
    rewrite env_sum_double; trivial.
  Qed.

  Lemma beta_lowering : forall M (Mapp: isApp M) (MLabs: isAbs (appBodyL Mapp)),
    env (subst (beta_subst M Mapp MLabs)) |= 0 :! .

  Proof. intros. rewrite beta_env. right; trivial. Qed.

  Inductive BetaStep : relation Term :=
  | Beta: forall M (Mapp: isApp M) (MLabs: isAbs (appBodyL Mapp)),
      BetaStep M
      (lower (subst (beta_subst M Mapp MLabs)) (beta_lowering M Mapp MLabs)).

  Definition BetaReduction := Reduction BetaStep.

  Notation "M -b-> N" := (BetaReduction M N) (at level 30).

  Lemma beta_type: forall M (Mapp: isApp M) (MLabs: isAbs (appBodyL Mapp)),
    absType MLabs = type (appBodyR Mapp).

  Proof.
    intros.
    destruct M as [??? typingM].
    destruct typingM; try contr.
    assert (type (appBodyL Mapp) = A --> B).
    trivial.
    rewrite (abs_type (appBodyL Mapp) MLabs H); trivial.
  Qed.

  Lemma beta_notFunS: forall M N, M -b-> N -> isFunS M -> False.

  Proof.
    intros M N MN.
    term_inv M.
    unfold Tr in MN.
    inversion MN; term_inv M.
    inversion H; try_solve.
  Qed.

  Lemma beta_direct_funApp : forall M (Mapp: isApp M)
    (MLabs: isAbs (appBodyL Mapp)), isFunS (appHead M) -> False.

  Proof.
    intros M Mapp MLabs Mhead.
    absurd (isFunS (appHead M)); trivial.
    rewrite (appHead_app M Mapp) in Mhead.
    assert (MLnotApp: ~isApp (appBodyL Mapp)).
    apply abs_isnot_app; trivial.
    rewrite (appHead_notApp (appBodyL Mapp) MLnotApp) in Mhead.
    exfalso. term_inv (appBodyL Mapp).
  Qed.

  Lemma app_beta_isapp : forall M N f,
    M -b-> N -> term (appHead M) = ^f -> isApp N.

  Proof.
    intro M; term_inv M.
     (* function symbol *)
    intros; exfalso.
    apply beta_notFunS with Tr N; trivial.
    unfold Tr; auto with terms.
     (* application *)
    intros N f MbN Mhead.
    inversion MbN; try solve [contr | trivial].
     (* direct beta step *)
    exfalso. inversion H.
    apply beta_direct_funApp with Tr I; eauto with terms.
  Qed.

  Lemma app_beta_headSymbol : forall M N f, M -b-> N -> term (appHead M) = ^f ->
    term (appHead N) = ^f.

  Proof.
    destruct M as [E Pt T TypM].
    induction TypM; simpl; intros N f' Nbeta Mhead; try discr;
      inversion Nbeta; try contr.
    inversion H; contr.
     (* 1) direct beta reduction (left applicant - abstraction) *)
    inversion H. exfalso.
    apply beta_direct_funApp with (buildT (TApp TypM1 TypM2)) Mapp0;
      eauto with terms.
     (* 2) beta reduction in left part of application *)
    term_inv N.
    unfold Tr.
    rewrite appHead_app_explicit.
    apply IHTypM1 with (N := @appBodyL (buildT (TApp T1 T2)) I).
    simpl; trivial.
    rewrite appHead_app_explicit in Mhead; trivial.
     (* 3) beta reduction in right part of application *)
    term_inv N.
    rewrite <- Mhead.
    unfold Tr.
    rewrite !appHead_app_explicit.
    congruence.
  Qed.

  Lemma app_beta_funS : forall M N,
    isFunS (appHead M) -> M -b-> N -> isFunS (appHead N).

  Proof.
    intros.
    destruct (funS_fun (appHead M) H) as [f Mf].
    apply funS_is_funS with f.
    apply (app_beta_headSymbol H0 Mf).
  Qed.

  Lemma app_beta_args : forall M N f,
    isApp M -> M -b-> N -> term (appHead M) = ^f ->
    exists l, exists el, isArg (fst el) M /\ isArg (snd el) N
      /\ fst el -b-> snd el /\
      appArgs M = fst l ++ fst el::snd l /\ appArgs N = fst l ++ snd el::snd l.

  Proof.
    destruct M as [E Pt T TypM].
    induction TypM; try solve [intros; inversion H].
    intros N f Mapp MbetaN Mhead.
    inversion MbetaN; try contr.
    inversion H. exfalso.
    apply beta_direct_funApp with (buildT (TApp TypM1 TypM2)) Mapp1;
      eauto with terms.
     (* -) beta in left argument *)
    simpl in *.
    rewrite (appHead_app (buildT (TApp TypM1 TypM2)) I) in Mhead;
      trivial.
    case (isApp_dec (buildT TypM1)).
    intro M1app.
     (*   - M = @(@(...), _) *)
    destruct (IHTypM1 (appBodyL Napp) f)
      as [[al ar] [[tl tr] [tlM [trN [tltr [Margs Nargs]]]]]];
      simpl in *; trivial.
    exists (al, ar ++ appBodyR Napp::nil); exists (tl, tr);
      repeat split; simpl; trivial.
    apply appArg_left with I; trivial.
    apply appArg_left with Napp; trivial.
    rewrite (appArgs_app (buildT (TApp TypM1 TypM2)) I); simpl.
    rewrite Margs; rewrite H0.
    rewrite <- ass_app; auto with datatypes.
    rewrite (appArgs_app N Napp); simpl.
    rewrite Nargs.
    rewrite <- ass_app; auto with datatypes.
     (*   - M = @(_, _) *)
    intro M1nApp; simpl in *.
    rewrite appHead_notApp in Mhead; simpl in Mhead. exfalso.
    apply beta_notFunS with (buildT TypM1) (appBodyL Napp);
      eauto with terms.
    trivial.
     (* -) beta in right argument *)
    term_inv N.
    exists (appArgs (buildT TypM1), nil(A:=Term)).
    exists (buildT TypM2, buildT T2); repeat split; simpl; trivial.
    apply appArg_right with I; trivial.
    apply appArg_right with I; trivial.
    rewrite appArgs_app with (buildT (TApp TypM1 TypM2)) I; trivial.
    rewrite appArgs_app with Tr I.
    rewrite H0; trivial.
  Qed.

  Lemma app_beta_args_eq : forall M N Q f,
    isApp M -> M -b-> N -> term (appHead M) = ^f ->
    isArg Q N -> (isArg Q M \/ (exists2 Mb, Mb -b-> Q & isArg Mb M)).

  Proof.
    intros M N Q f Mapp MbN Mhead QargN.
    destruct (app_beta_args Mapp MbN Mhead) as
      [[al ar] [[tl tr] [tlM [trN [tltr [Margs Nargs]]]]]];
      simpl in * .
    unfold isArg in QargN; rewrite Nargs in QargN.
    destruct (in_app_or QargN).
    left.
    unfold isArg; rewrite Margs; auto with datatypes.
    inversion H.
    right; exists tl.
    rewrite <- H0; trivial.
    unfold isArg; rewrite Margs; auto with datatypes.
    left.
    unfold isArg; rewrite Margs; auto with datatypes.
  Qed.

  Lemma beta_funS_normal : forall M N, isFunS M -> ~(M -b-> N).

  Proof. intros M N Mf MN. inversion MN; inversion H; term_inv M. Qed.

  Lemma beta_var_normal : forall M N, isVar M -> ~(M -b-> N).

  Proof. intros M N Mvar MN. inversion MN; inversion H; term_inv M. Qed.

  Lemma betaStep_env_preserving : forall M N, BetaStep M N -> env M = env N.

  Proof.
    intros.
    inversion H.
    rewrite lower_env.
    rewrite beta_env.
    unfold loweredEnv, finalSeg; simpl.
    rewrite initialSeg_full; trivial.
    lia.
  Qed.

  Lemma beta_env_preserving : forall M N, M -b-> N -> env M = env N.

  Proof.
    intros.
    apply Red_env_preserving with BetaStep; trivial.
    apply betaStep_env_preserving.
  Qed.

  Lemma betaStep_type_preserving : forall M N, BetaStep M N -> type M = type N.

  Proof.
    intros.
    inversion H.
    rewrite lower_type.
    rewrite subst_type.
    destruct M as [ME MPt MT M].
    destruct M; try contr.
    assert (MlT: type (appBodyL Mapp0) = A --> B); [simpl; trivial | idtac].
    rewrite (absBody_type (appBodyL Mapp0) MLabs MlT); simpl; trivial.
  Qed.

  Lemma subject_reduction : forall M N, M -b-> N -> type M = type N.

  Proof.
    intros.
    apply Red_type_preserving with BetaStep; trivial.
    apply betaStep_type_preserving.
  Qed.

  Lemma beta_monotonous : monotonous BetaReduction.

  Proof. unfold BetaReduction; apply red_monotonous. Qed.

  Lemma betaStep_conv_comp_aux : forall M M' N N' Q, M ~(Q) M' -> N ~(Q) N' ->
    BetaStep M N -> env M' = env N' -> BetaStep M' N'.

  Proof.
    intros M M' N N' Q MQM' NQN' MN M'N'env.
    inversion MN.
    assert (M'app: isApp M').
    assert (MM' : M ~ M') by (exists Q; trivial).
    rewrite <- MM'; trivial.
    assert (M'Labs: isAbs (appBodyL M'app)).
    setoid_replace (appBodyL M'app) with (appBodyL Mapp0); trivial.
    apply app_conv_app_left.
    sym; exists Q; trivial.
    replace N' with (lower (subst (beta_subst M' M'app M'Labs))
      (beta_lowering M' M'app M'Labs)).
    constructor.
    rewrite terms_lift_eq with (lower (subst (beta_subst M' M'app M'Labs))
      (beta_lowering M' M'app M'Labs)) N'; trivial.
    apply term_eq.
    autorewrite with terms datatypes using unfold liftedEnv, loweredEnv; simpl.
    rewrite M'N'env; trivial.
    rewrite prelift_prelower.
    autorewrite with terms.
    rewrite <- lift_term.
    apply (@presubst_singleton_conv_sim
      (term (absBody MLabs)) (term (absBody M'Labs))
      (lift (appBodyR Mapp0) 1) (lift (appBodyR M'app) 1) (envSubst_lift1 Q)
      (term (lift N 1)) (term (lift N' 1))
    ).
    destruct Q; simpl; trivial.
    assert (Conv: (absBody MLabs) ~(envSubst_lift1 Q) (absBody M'Labs)).
    apply abs_conv_absBody_aux.
    apply app_conv_app_left_aux; trivial.
    destruct Conv; trivial.
    apply terms_conv_conv_lift.
    apply app_conv_app_right_aux; trivial.
    assert (Conv: (lift N 1) ~(envSubst_lift1 Q) (lift N' 1)).
    apply terms_conv_conv_lift; trivial.
    destruct Conv; trivial.
    rewrite <- H0.
    rewrite prelift_prelower.
    autorewrite with terms using trivial.
  Qed.

  Lemma beta_conv_comp : forall M M' N N' Q,
    M ~(Q) M' -> N ~(Q) N' -> M -b-> N -> env M' = env N' -> M' -b-> N'.

  Proof.
    intros.
    unfold BetaReduction.
    apply red_conv_comp with M N Q; trivial.
    intros.
    apply betaStep_conv_comp_aux with M0 N0 Q0; trivial.
  Qed.

  Lemma subst_at0 : forall M G (MG: correct_subst M (None :: lift_subst G 1)),
    env M |= 0 :! -> env (subst MG) |= 0 :! .

  Proof.
    intros.
    rewrite subst_env.
    destruct (env M).
    rewrite subst_ran_cons_none.
    destruct (subst_empty_dec G); simpl.
    rewrite subst_ran_lifted_empty; trivial.
    rewrite subst_ran_lifted_ne; solve [trivial | constructor 2; trivial].
    destruct o.
    destruct H; try_solve.
    simpl.
    rewrite subst_ran_cons_none.
    destruct (subst_empty_dec G); simpl.
    rewrite subst_ran_lifted_empty; trivial.
    rewrite subst_ran_lifted_ne; solve [trivial | constructor 2; trivial].
  Qed.

  Lemma subst_envs_comp_cons : forall G,
    subst_envs_comp G -> subst_envs_comp (None :: G).

  Proof.
    intros.
    intros i j Ti Tj Gi Gj.
    destruct i; destruct j.
    try_solve.
    inversion Gi.
    inversion Gj.
    apply (H i j).
    inversion Gi; trivial.
    inversion Gj; trivial.
  Qed.

  Lemma correct_subst_lift : forall M N G (M0: env M |= 0 :!),
    correct_subst N G -> N = lower M M0 ->
    correct_subst M (None :: lift_subst G 1).

  Proof.
    intros ???? [envNG domNG ranNG] H.
    rewrite H in domNG.
    rewrite H in ranNG.
    rewrite lower_env in domNG.
    rewrite lower_env in ranNG.
    clear H.
    constructor.
    apply subst_envs_comp_cons.
    apply lifted_subst_envs_comp; trivial.
    destruct (env M).
    apply env_comp_empty.
    destruct o.
    destruct M0; try_solve.
    simpl.
    rewrite subst_dom_lifted.
    apply env_comp_cons; auto.
    unfold loweredEnv in domNG.
    simpl in domNG.
    rewrite finalSeg_cons in domNG; trivial.
    simpl.
    rewrite subst_ran_cons_none.
    rewrite subst_dom_lifted.
    destruct (subst_empty_dec G).
    rewrite subst_ran_lifted_empty; trivial.
    simpl; apply env_comp_sym; apply env_comp_empty.
    rewrite subst_ran_lifted_ne; trivial.
    simpl.
    destruct (env M).
    apply env_comp_empty.
    destruct o.
    destruct M0; try_solve.
    apply env_comp_cons; auto.
    unfold loweredEnv in ranNG.
    simpl in ranNG.
    rewrite finalSeg_cons in ranNG; trivial.
  Qed.

  Lemma lower_subst_aux : forall M G i, env M |= i :! ->
    presubst_aux (prelower_aux (term M) i) i (copy i None ++ G) =
    prelower_aux (presubst_aux (term M) i
      (copy i None ++ None :: lift_subst G 1)) i.

  Proof.
    destruct M as [E Pt TM M].
    induction M; intros G i Mi; unfold prelower, presubst; simpl.
     (* variable *)
    destruct (Compare_dec.le_gt_dec i x); simpl.
    destruct (eq_nat_dec i x).
     (*   - x = i *)
    rewrite e in Mi.
    exfalso; eapply varD_UD_absurd; eauto.
     (*   - x > i *)
    destruct x; simpl. lia.
    replace (copy i None ++ None :: lift_subst G 1) with
      ((None :: copy i None) ++ lift_subst G 1).
    simpl.
    repeat rewrite nth_app_right; rewrite copy_length; try lia.
    destruct (varSubst_dec G (x - i)) as [[T GT] | Gn].
    rewrite GT, (nth_lift_subst_s G 1 (x - i) GT), !lift_term, <- prelift_fold.
    apply prelower_prelift.
    set (w := var_notSubst_lift 1 Gn).
    inversion Gn; inversion w; rewrite H; rewrite H0; simpl;
      destruct (Compare_dec.le_gt_dec i (S x));
	solve [trivial | lia].
    rewrite <- list_app_first_last.
    rewrite <- copy_add; trivial.
    rewrite <- app_nil_end; trivial.
     (*   - x < i *)
    rewrite !nth_app_left, nth_copy_in.
    simpl.
    destruct (Compare_dec.le_gt_dec i x); trivial.
    lia.
    lia.
    rewrite copy_length; lia.
    rewrite copy_length; lia.
     (* function symbol *)
    trivial.
     (* abstraction *)
    set (w := IHM G (S i)).
    simpl in w.
    rewrite w; trivial.
     (* application *)
    rewrite IHM1; trivial.
    rewrite IHM2; trivial.
  Qed.

  Lemma lower_subst : forall M N G (M0: env M |= 0 :!) (MG: correct_subst N G)
    (MG': correct_subst M (None :: lift_subst G 1))
    (MG'0: env (subst MG') |= 0 :! := (subst_at0 G MG' M0)),
    N = lower M M0 -> subst MG = lower (subst MG') MG'0.

  Proof.
    intros.
    apply term_eq; autorewrite with terms; rewrite H; autorewrite with terms.

    destruct M as [envM ???].
    autorewrite with terms using simpl.
    unfold loweredEnv; simpl.
    destruct (subst_empty_dec G).
    destruct envM; simpl.
    autorewrite with terms; trivial.
    autorewrite with terms datatypes; trivial.
    destruct o; autorewrite with datatypes; trivial.
    destruct envM; simpl.
    autorewrite with datatypes terms.
    destruct (subst_ran G); trivial.
    destruct o; autorewrite with datatypes terms using simpl; trivial.

    unfold presubst, prelower.
    apply (lower_subst_aux M G M0).
  Qed.

  Lemma lower_eq : forall M N (M0: env M |= 0 :!) (N0: env N |= 0 :!), M = N ->
    lower M M0 = lower N N0.

  Proof.
    intros.
    apply term_eq.
    rewrite !lower_env; rewrite H; trivial.
    rewrite !lower_term; rewrite H; trivial.
  Qed.

  Lemma subst_single_eq : forall M M' P P' (MP: correct_subst M {x/P})
    (MP': correct_subst M' {x/P'}), M = M' -> P = P' -> subst MP = subst MP'.

  Proof.
    intros.
    apply term_eq.
    rewrite !subst_env, H, H0; trivial.
    rewrite !subst_term, H, H0; trivial.
  Qed.

  Lemma double_subst_aux : forall M P G i
    (PG: correct_subst P (None :: lift_subst G 1)),
    presubst_aux (presubst_aux M i (copy i None ++ {x/P}))
    i (copy (S i) None ++ lift_subst G 1) =
    presubst_aux (presubst_aux M i (copy (S i) None ++ lift_subst G 1))
    i (copy i None ++ {x/subst PG}).

  Proof.
    induction M; unfold presubst; intros; simpl.

    destruct (Compare_dec.gt_eq_gt_dec i x) as [[x_gt_i | x_eq_i] | x_lt_i].
    rewrite nth_beyond; autorewrite with terms datatypes; simpl; try lia.
    replace (None :: copy i None ++ lift_subst G 1) with
      (copy (S i) None ++ lift_subst G 1); trivial.
    rewrite nth_app_right; autorewrite with terms datatypes; try lia.
    destruct (varSubst_dec G (x - S i)) as [[T GT] | Gn].
    rewrite (var_subst_lift 1 GT), !lift_term, <- prelift_fold,
      presubst_beyond; trivial.
    autorewrite with datatypes using simpl; try lia.
    destruct (var_notSubst_lift 1 Gn); rewrite H;
      replace (%x) with (prelift (%0) x); trivial;
      rewrite presubst_beyond; solve
	[ trivial
	| autorewrite with datatypes using simpl; try lia
	].

    rewrite x_eq_i.
    rewrite nth_app_right; autorewrite with datatypes using try lia.
    rewrite <- Minus.minus_n_n; simpl.
    replace (None :: copy x None ++ lift_subst G 1) with
      (copy (S x) None ++ lift_subst G 1); trivial.
    rewrite nth_app_left; autorewrite with datatypes terms using simpl;
      try lia.
    rewrite nth_app_right; autorewrite with datatypes terms using simpl;
      try lia.
    rewrite <- Minus.minus_n_n; simpl.
    autorewrite with terms.
    rewrite <- presubst_prelift_comm; simpl.
    rewrite subst_lift_subst; simpl.
    rewrite lift_subst_distr.
    rewrite lift_empty_subst.
    rewrite <- copy_add; trivial.

    replace (None :: copy i None ++ lift_subst G 1) with
      (copy (S i) None ++ lift_subst G 1); trivial.
    rewrite !nth_app_left; autorewrite with terms datatypes using simpl;
      try lia.
    replace (None :: copy i None ++ lift_subst G 1) with
      (copy (S i) None ++ lift_subst G 1); trivial.
    replace (None :: copy i (None (A:=Term)))
      with (copy (S i) (None (A:=Term))); trivial.
    rewrite !nth_app_left; autorewrite with terms datatypes using simpl;
      try lia.
    rewrite nth_app_left; autorewrite with terms datatypes using trivial.

    trivial.
    replace (None :: copy i None ++ {x/P}) with
      (copy (S i) None ++ {x/P}); trivial.
    replace (None :: None :: copy i None ++ lift_subst G 1) with
      (copy (S (S i)) None ++ lift_subst G 1); trivial.
    replace (None :: copy i None ++ {x/subst PG}) with
      (copy (S i) None ++ {x/subst PG}); trivial.
    rewrite (IHM P G (S i) PG); trivial.
    replace (None :: copy i None ++ lift_subst G 1) with
      (copy (S i) None ++ lift_subst G 1); trivial.
    rewrite <- IHM1.
    rewrite <- IHM2.
    trivial.
  Qed.

  Lemma double_subst : forall M G P (MP: correct_subst M {x/P})
    (MPG: correct_subst (subst MP) (None :: lift_subst G 1))
    (MG: correct_subst M (None :: lift_subst G 1))
    (PG: correct_subst P (None :: lift_subst G 1))
    (MGP: correct_subst (subst MG) {x/subst PG}), subst MPG = subst MGP.

  Proof.
    intros.
    apply term_eq.

    autorewrite with terms.
    cut (tail (env M) [+] tail (env P) [-] subst_dom G [+] subst_ran G =
      tail (env M) [-] subst_dom G [+] subst_ran G [+]
      (tail (env P) [-] subst_dom G [+] subst_ran G)).
    destruct (subst_empty_dec G).
    (*SLOW*)destruct (env M); destruct (env P); try destruct o;
      try destruct o0; simpl; (autorewrite with terms using simpl); try_solve.
    (*VERY SLOW*)destruct (env M); destruct (env P); try destruct o;
      try destruct o0; simpl; (autorewrite with terms using simpl);
      try destruct (subst_ran G); try destruct (subst_dom G);
      try destruct e; try destruct o; try destruct o0; try_solve.
    rewrite env_sum_assoc.
    rewrite <- (env_sum_assoc (subst_ran G)).
    rewrite env_sum_remove_double.
    rewrite <- env_sum_assoc.
    rewrite env_sub_move; trivial.

    autorewrite with terms datatypes.
    unfold presubst.
    set (w := double_subst_aux (term M) G 0 PG).
    simpl in w; trivial.
  Qed.

  Lemma double_lift : forall M G
    (CS: correct_subst (lift M 1) (None :: lift_subst G 1))
    (CS': correct_subst M G), subst CS = lift (subst CS') 1.

  Proof.
    intros.
    apply term_eq.
    destruct (subst_empty_dec G);
      autorewrite with terms datatypes using unfold liftedEnv; simpl; trivial.
    autorewrite with terms.
    replace (None :: lift_subst G 1) with (copy (S 0) None ++ lift_subst G 1);
    trivial.
    apply presubst_prelift_comm.
  Qed.

  Lemma subst_on_beta : forall M (Mapp: isApp M) (MLabs: isAbs (appBodyL Mapp))
    G (CS: correct_subst M G)
    (CSin: correct_subst (absBody MLabs) (None :: lift_subst G 1))
    (CSapp: isApp (subst CS) := app_subst_app Mapp CS)
    (CSLabs: isAbs (appBodyL CSapp)),
    subst CSin = absBody CSLabs.

  Proof.
    intros; apply term_eq.

    assert (absType MLabs = absType CSLabs).
    apply type_eq_absType_eq.
    unfold CSapp; apply type_appBodyL_subst.
    destruct (subst_empty_dec G); autorewrite with terms using unfold decl;
      try_solve.

    autorewrite with terms datatypes using simpl.
    rewrite (absBody_term (appBodyL CSapp) CSLabs (A := absType MLabs)
      (Pt := presubst (term (absBody MLabs)) (None :: lift_subst G 1)));
      trivial.
    rewrite (appBodyL_term (subst CS) (PtL := \absType MLabs =>
      presubst (term (absBody MLabs)) (None::lift_subst G 1))
      (PtR := presubst (term (appBodyR Mapp)) G)); trivial.
    autorewrite with terms.
    rewrite (app_term M Mapp).
    rewrite (abs_term (appBodyL Mapp) MLabs).
    unfold presubst; simpl.
    rewrite subst_lift_subst; trivial.
  Qed.

  Lemma beta_lower_subst : forall M N G (Mapp: isApp M)
    (MLabs: isAbs (appBodyL Mapp))
    (MN: correct_subst M G) (NS: correct_subst N G)
    (MNS_app: isApp (subst MN) := app_subst_app Mapp MN)
    (MNS_Labs: isAbs (appBodyL MNS_app)),
    N = lower (subst (beta_subst M Mapp MLabs)) (beta_lowering M Mapp MLabs) ->
    subst NS = lower (subst (beta_subst (subst MN) MNS_app MNS_Labs))
      (beta_lowering (subst MN) MNS_app MNS_Labs).

  Proof.
    intros.
    set (s0 := correct_subst_lift (subst (beta_subst M Mapp MLabs))
      (beta_lowering M Mapp MLabs) NS H).
    rewrite (lower_subst (beta_lowering M Mapp MLabs) NS s0 H).
    apply lower_eq.
    assert (s1: correct_subst (absBody MLabs) (None :: lift_subst G 1)).
    inversion MN; inversion NS; inversion s0; prove_correct_subst.
    assert
      (s2: correct_subst (lift (appBodyR Mapp) 1) (None :: lift_subst G 1)).
    inversion MN; inversion NS; inversion s0; prove_correct_subst.
    assert (s3: correct_subst (subst s1) {x/subst s2}).
    constructor.
    apply subst_envs_comp_single.
    assert (forall E, {x/type (appBodyR Mapp)} [<->] Some (absType MLabs) :: E).
    intro; apply env_comp_cons.
    auto with terms.
    left; rewrite beta_type; trivial.
    destruct (subst_empty_dec G); autorewrite with terms using simpl; auto.
    destruct (subst_empty_dec G);
      autorewrite with terms datatypes using simpl; auto with terms.
    rewrite (double_subst G (beta_subst M Mapp MLabs) s0 s1 s2 s3).
    apply term_eq.
    destruct (subst_empty_dec G);
      autorewrite with datatypes terms using simpl; trivial.
    autorewrite with datatypes terms using simpl.
    assert (Leq: presubst (term (absBody MLabs)) (None :: lift_subst G 1) =
      term (absBody MNS_Labs)).
    cut (term (subst s1) = term (absBody MNS_Labs)).
    autorewrite with terms.
    intro; rewrite H0; trivial.
    rewrite (subst_on_beta Mapp MLabs MN s1 MNS_Labs); trivial.
    assert (R'eq: subst (subst_appR_c Mapp MN) = appBodyR MNS_app).
    destruct (app_subst Mapp MN).
    rewrite <- H1.
    rewrite (app_proof_irr (subst MN) (app_subst_app Mapp MN) MNS_app); trivial.
    assert (Req: subst s2 = lift (appBodyR MNS_app) 1).
    rewrite (double_lift s2 (subst_appR_c Mapp MN)).
    rewrite R'eq; trivial.
    try_solve.
  Qed.

  Lemma betaStep_subst_stable : forall M N G (MS: correct_subst M G)
    (NS: correct_subst N G), BetaStep M N -> BetaStep (subst MS) (subst NS).

  Proof.
    intros M N G MS NS MN.
    inversion MN.
    set (MNS_app := app_subst_app Mapp0 MS).
    assert (MNS_Labs: isAbs (appBodyL MNS_app)).
    eapply abs_isAbs.
    assert (MS_term : term (subst MS) = presubst_aux (term (appBodyL Mapp0))
      0 G [presubst_aux (term (appBodyR Mapp0)) 0 G]).
    rewrite subst_term; term_inv M.
    rewrite (appBodyL_term (subst MS) MS_term).
    rewrite (abs_term (appBodyL Mapp0) MLabs).
    simpl; eauto.
    rewrite (beta_lower_subst Mapp0 MLabs MS NS MNS_Labs); auto.
    constructor.
  Qed.

  Lemma beta_subst_stable : forall M N G (MS: correct_subst M G)
    (NS: correct_subst N G), M -b-> N -> subst MS -b-> subst NS.

  Proof.
    destruct M as [E Pt T M]; induction M; intros.

     (* variable *)
    absurd (buildT (TVar v) -b-> N); trivial.
    apply beta_var_normal; simpl; trivial.

     (* function symbol *)
    absurd (buildT (TFun E f) -b-> N); trivial.
    apply beta_funS_normal; simpl; trivial.

     (* abstraction *)
    inversion H; try_solve.
    inversion H0; try_solve.
    clear Mabs.
    assert (Mabs: isAbs (buildT (TAbs M))).
    simpl; trivial.
    destruct (abs_subst Mabs MS) as [Ms_type Ms_body].
    destruct (abs_subst Nabs NS) as [Ns_type Ns_body].
    constructor 4 with (abs_subst_abs Mabs MS) (abs_subst_abs Nabs NS).
    rewrite Ms_type; rewrite Ns_type; trivial.
    rewrite Ms_body; rewrite Ns_body.
    apply IHM; trivial.

     (* application *)
    inversion H; try_solve.
     (*  - beta reduction *)
    constructor 1.
    apply betaStep_subst_stable; trivial.

     (*  - reduction in left argument *)
    clear Mapp; assert (Mapp: isApp (buildT (TApp M1 M2))); simpl; trivial.
    destruct (app_subst Mapp MS) as [Ml Mr].
    destruct (app_subst Napp NS) as [Nl Nr].
    constructor 2 with (app_subst_app Mapp MS) (app_subst_app Napp NS).
    rewrite Ml; rewrite Nl; apply IHM1; trivial.
    rewrite Mr; rewrite Nr; trivial.
    apply term_eq.
    rewrite !subst_env, <- H1; trivial.
    rewrite !subst_term, <- H1; trivial.

     (*  - reduction in right argument *)
    clear Mapp; assert (Mapp: isApp (buildT (TApp M1 M2))); simpl; trivial.
    destruct (app_subst Mapp MS) as [Ml Mr].
    destruct (app_subst Napp NS) as [Nl Nr].
    constructor 3 with (app_subst_app Mapp MS) (app_subst_app Napp NS).
    rewrite Mr; rewrite Nr; apply IHM2; trivial.
    rewrite Ml; rewrite Nl; trivial.
    apply term_eq.
    rewrite !subst_env, <- H1; trivial.
    rewrite !subst_term, <- H1; trivial.
  Qed.

  Lemma beta_abs_reduct : forall M (Mabs: isAbs M) N, M -b-> N ->
    exists Nabs: isAbs N, absBody Mabs -b-> absBody Nabs.

  Proof.
    intros M Mabs N MN.
    inversion MN; term_inv M; try_solve.
    inversion H; try_solve.
    exists Nabs; trivial.
  Qed.

  Lemma beta_app_reduct : forall M N (Mapp: isApp M),
    M -b-> N ->
    (exists MLabs: isAbs (appBodyL Mapp),
      N = lower (subst (beta_subst M Mapp MLabs)) (beta_lowering M Mapp MLabs))
    \/ exists Napp: isApp N,
      (appBodyL Mapp  =   appBodyL Napp /\ appBodyR Mapp -b-> appBodyR Napp)
      \/ (appBodyL Mapp -b-> appBodyL Napp /\ appBodyR Mapp  =   appBodyR Napp).

  Proof.
    intros M N Mapp MN.
    inversion MN; term_inv M; try_solve.
    left; inversion H.
    exists MLabs.
    rewrite (app_proof_irr Tr Mapp Mapp1); trivial.
    right; exists Napp; fo.
    right; exists Napp; fo.
  Qed.

  Lemma beta_var_consistent : forall M N,
    M -b-> N -> envSubset (activeEnv N) (activeEnv M).

  Proof.
    intros.
    apply red_var_consistent with BetaStep; trivial.
    clear M N H; intros M N MN.
    destruct MN.
    rewrite activeEnv_lower.
    rewrite (activeEnv_app M Mapp).
    rewrite (activeEnv_abs (appBodyL Mapp) MLabs).
    destruct (isVarDecl_dec (activeEnv (absBody MLabs)) 0) as [[B Ml0] | Mln].
    assert (Mlb0: exists A, activeEnv (absBody MLabs) |= 0 := A).
    exists B; trivial.
    rewrite (singleton_subst_activeEnv_subst (beta_subst M Mapp MLabs)
      (singletonSubst_cond (lift (appBodyR Mapp) 1)) Mlb0).
    rewrite (activeEnv_lift (appBodyR Mapp) 1).
    simpl; autorewrite with datatypes using unfold loweredEnv; simpl.
    apply env_subset_refl.
    rewrite (singleton_subst_activeEnv_noSubst (beta_subst M Mapp MLabs) Mln
      (singletonSubst_cond (lift (appBodyR Mapp) 1))); trivial.
    unfold loweredEnv; autorewrite with datatypes using simpl.
    apply env_subset_sum_l.
    simpl.
    apply env_comp_subset with (tail (env (subst (beta_subst M Mapp MLabs))))
      (env (appBodyR Mapp)).
    autorewrite with terms datatypes using simpl; auto with terms.
    apply env_subset_tail; apply activeEnv_subset.
    apply activeEnv_subset.
    rewrite finalSeg1_tail.
    apply env_subset_refl.
  Qed.

  Lemma betaStep_dec: forall M N, {BetaStep M N} + {~BetaStep M N}.

  Proof.
    intros.
    destruct (isApp_dec M) as [Mapp | Mnapp].
    destruct (isAbs_dec (appBodyL Mapp)) as [MLabs | MLnabs].
    destruct (eq_Term_dec N (lower (subst (beta_subst M Mapp MLabs))
      (beta_lowering M Mapp MLabs))).
    left; rewrite e; constructor.
    right; intro MN; inversion MN.
    apply n; rewrite <- H0.
    apply term_eq.
    autorewrite with terms using trivial.
    autorewrite with terms using trivial.
    replace (absBody MLabs0) with (absBody MLabs).
    replace (appBodyR Mapp1) with (appBodyR Mapp); trivial.
    term_inv M.
    apply absBody_eq; term_inv M.
    right; intro MN; inversion MN.
    absurd (isAbs (appBodyL Mapp1)); trivial.
    replace (appBodyL Mapp1) with (appBodyL Mapp); trivial.
    term_inv M.
    right; intro MN; inversion MN; try_solve.
  Qed.

  Lemma beta_dec: forall M N, {M -b-> N} + {~ M -b-> N}.

  Proof.
    intros; unfold BetaReduction.
    apply red_dec.
    apply betaStep_dec.
  Qed.

End TermsBeta.


From Hammer Require Import Hammer.

Require Import ExtLib.Structures.Maps.
Require Import ExtLib.Structures.Functor.
Require Import ExtLib.Data.Option.
Require Import ExtLib.Data.Positive.
Require Import ExtLib.Tactics.Cases.

Set Implicit Arguments.
Set Strict Implicit.

Section pmap.
Variable T : Type.
Inductive pmap : Type :=
| Empty
| Branch : option T -> pmap -> pmap -> pmap.

Definition pmap_here (m : pmap) : option T :=
match m with
| Empty => None
| Branch d _ _ => d
end.

Definition pmap_left (m : pmap) : pmap :=
match m with
| Empty => Empty
| Branch _ l _ => l
end.

Definition pmap_right (m : pmap) : pmap :=
match m with
| Empty => Empty
| Branch _ _ r => r
end.

Fixpoint pmap_lookup (p : positive) (m : pmap) {struct p} : option T :=
match m with
| Empty => None
| Branch d l r =>
match p with
| xH => d
| xO p => pmap_lookup p l
| xI p => pmap_lookup p r
end
end.

Fixpoint pmap_insert (p : positive) (v : T) (m : pmap) {struct p} : pmap :=
match p with
| xH => Branch (Some v) (pmap_left m) (pmap_right m)
| xO p =>
Branch (pmap_here m) (pmap_insert p v (pmap_left m)) (pmap_right m)
| xI p =>
Branch (pmap_here m) (pmap_left m) (pmap_insert p v (pmap_right m))
end.

Definition branch (o : option T) (l r : pmap) : pmap :=
match o , l , r with
| None , Empty , Empty => Empty
| _ , _ , _ => Branch o l r
end.

Fixpoint pmap_remove (p : positive) (m : pmap) {struct p} : pmap :=
match m with
| Empty => Empty
| Branch d l r =>
match p with
| xH => branch None l r
| xO p => branch d (pmap_remove p l) r
| xI p => branch d l (pmap_remove p r)
end
end.

Definition pmap_empty : pmap := Empty.

Fixpoint pmap_union (f m : pmap) : pmap :=
match f with
| Empty => m
| Branch d l r =>
Branch (match d with
| Some x => Some x
| None => pmap_here m
end) (pmap_union l (pmap_left m)) (pmap_union r (pmap_right m))
end.

Global Instance Map_pmap : Map positive T pmap :=
{ empty := pmap_empty
; add := pmap_insert
; remove := pmap_remove
; lookup := pmap_lookup
; union := pmap_union
}.

Lemma tilde_1_inj_neg : forall k k',
(k~1)%positive <> (k'~1)%positive -> k <> k'.
Proof. hammer_hook "FMapPositive" "FMapPositive.tilde_1_inj_neg".
induction k; destruct k'; intuition;
try match goal with
| H : _ = _ |- _ => inversion H; clear H; subst
end; intuition eauto.
Qed.

Lemma tilde_0_inj_neg : forall k k',
(k~0)%positive <> (k'~0)%positive -> k <> k'.
Proof. hammer_hook "FMapPositive" "FMapPositive.tilde_0_inj_neg".
induction k; destruct k'; intuition;
try match goal with
| H : _ = _ |- _ => inversion H; clear H; subst
end; intuition eauto.
Qed.

Lemma pmap_lookup_insert_empty : forall k k' v,
k <> k' ->
pmap_lookup k' (pmap_insert k v Empty) = None.
Proof. hammer_hook "FMapPositive" "FMapPositive.pmap_lookup_insert_empty".
induction k; destruct k'; simpl; intros;
eauto using tilde_0_inj_neg, tilde_1_inj_neg.
destruct k'; simpl; auto.
destruct k'; simpl; auto.
destruct k'; simpl; auto.
destruct k'; simpl; auto.
congruence.
Qed.

Lemma lookup_empty : forall k, pmap_lookup k Empty = None.
Proof. hammer_hook "FMapPositive" "FMapPositive.lookup_empty".
destruct k; reflexivity.
Qed.

Hint Rewrite lookup_empty pmap_lookup_insert_empty
using (eauto using tilde_1_inj_neg, tilde_1_inj_neg) : pmap_rw.

Lemma pmap_lookup_insert_eq
: forall (m : pmap) (k : positive) (v : T),
pmap_lookup k (pmap_insert k v m) = Some v.
Proof. hammer_hook "FMapPositive" "FMapPositive.pmap_lookup_insert_eq".
intros m k; revert m.
induction k; simpl; intros; forward; Cases.rewrite_all_goal; eauto.
Qed.

Lemma pmap_lookup_insert_Some_neq
: forall (m : pmap) (k : positive) (v : T) (k' : positive),
k <> k' ->
forall v' : T,
pmap_lookup k' m = Some v' <-> pmap_lookup k' (pmap_insert k v m) = Some v'.
Proof. hammer_hook "FMapPositive" "FMapPositive.pmap_lookup_insert_Some_neq".
intros m k; revert m.
induction k; simpl; intros; forward; Cases.rewrite_all_goal;
autorewrite with pmap_rw; eauto.
{ destruct k'; simpl; destruct m; simpl;
autorewrite with pmap_rw; Cases.rewrite_all_goal; try reflexivity.
erewrite IHk; eauto using tilde_1_inj_neg. reflexivity. }
{ destruct k'; simpl; destruct m; simpl;
autorewrite with pmap_rw; Cases.rewrite_all_goal; try reflexivity; try congruence.
erewrite IHk. reflexivity. eauto using tilde_0_inj_neg. }
{ destruct k'; simpl; destruct m; simpl;
autorewrite with pmap_rw; Cases.rewrite_all_goal; try reflexivity; try congruence. }
Qed.

Lemma pmap_lookup_insert_None_neq
: forall (m : pmap) (k : positive) (v : T) (k' : positive),
k <> k' ->
pmap_lookup k' m = None <-> pmap_lookup k' (pmap_insert k v m) = None.
Proof. hammer_hook "FMapPositive" "FMapPositive.pmap_lookup_insert_None_neq".
intros m k; revert m.
induction k; simpl; intros; forward; Cases.rewrite_all_goal;
autorewrite with pmap_rw; eauto.
{ destruct k'; simpl; destruct m; simpl;
autorewrite with pmap_rw; Cases.rewrite_all_goal; try reflexivity.
erewrite IHk; eauto using tilde_1_inj_neg. reflexivity. }
{ destruct k'; simpl; destruct m; simpl;
autorewrite with pmap_rw; Cases.rewrite_all_goal; try reflexivity; try congruence.
erewrite IHk. reflexivity. eauto using tilde_0_inj_neg. }
{ destruct k'; simpl; destruct m; simpl;
autorewrite with pmap_rw; Cases.rewrite_all_goal; try reflexivity; try congruence. }
Qed.

Lemma pmap_lookup_insert_neq
: forall (m : pmap) (k : positive) (v : T) (k' : positive),
k <> k' ->
forall v' : T,
pmap_lookup k' (pmap_insert k v m) = pmap_lookup k' m.
Proof. hammer_hook "FMapPositive" "FMapPositive.pmap_lookup_insert_neq".
intros.
remember (pmap_lookup k' m).
destruct o; [
apply pmap_lookup_insert_Some_neq; intuition |
apply pmap_lookup_insert_None_neq; intuition].
Qed.

Lemma pmap_lookup_remove_eq
: forall (m : pmap) (k : positive) (v : T),
pmap_lookup k (pmap_remove k m) <> Some v.
Proof. hammer_hook "FMapPositive" "FMapPositive.pmap_lookup_remove_eq".
induction m; destruct k; simpl; intros; try congruence.
{ destruct o; simpl; eauto.
destruct m1; simpl; eauto.
destruct (pmap_remove k m2) eqn:?; try congruence.
rewrite <- Heqp. eauto. }
{ destruct o; simpl; eauto.
destruct (pmap_remove k m1) eqn:?; try congruence.
- destruct m2; try congruence; eauto.
destruct k; simpl; congruence.
- rewrite <- Heqp. eauto. }
{ destruct m1; try congruence.
destruct m2; try congruence. }
Qed.

Lemma pmap_lookup_remove_neq
: forall (m : pmap) (k k' : positive),
k <> k' ->
forall v' : T, pmap_lookup k' m = Some v' <-> pmap_lookup k' (pmap_remove k m) = Some v'.
Proof. hammer_hook "FMapPositive" "FMapPositive.pmap_lookup_remove_neq".
induction m.
Local Ltac t :=
unfold branch;
repeat match goal with
| |- context [ match ?X with _ => _ end ] =>
lazymatch X with
| match _ with _ => _ end => fail
| _ => destruct X eqn:?; subst; try tauto
end
end.
{ destruct k; simpl; split; try congruence. }
{ destruct k', k; simpl; intros; try solve [ t; rewrite lookup_empty; tauto ].
{ assert (k <> k') by congruence.
rewrite IHm2; eauto. simpl. t. rewrite lookup_empty. tauto. }
{ assert (k <> k') by congruence.
rewrite IHm1; eauto. simpl. t. rewrite lookup_empty. tauto. } }
Qed.

Global Instance MapOk_pmap : MapOk (@eq _) Map_pmap.
Proof. hammer_hook "FMapPositive" "FMapPositive.MapOk_pmap".
refine {| mapsto := fun k v m => pmap_lookup k m = Some v |}.
{ abstract (induction k; simpl; congruence). }
{ abstract (induction k; simpl; intros; forward). }
{ eauto using pmap_lookup_insert_eq. }
{ eauto using pmap_lookup_insert_Some_neq. }
{ eauto using pmap_lookup_remove_eq. }
{ eauto using pmap_lookup_remove_neq. }
Defined.

Definition from_list : list T -> pmap :=
(fix from_list acc i ls {struct ls} :=
match ls with
| nil => acc
| List.cons l ls =>
from_list (pmap_insert i l acc) (Pos.succ i) ls
end) Empty 1%positive.

End pmap.

Arguments Empty {_}.
Arguments Branch {_} _ _ _.

Section fmap.
Variables T U : Type.
Variable f : T -> U.

Fixpoint fmap_pmap (m : pmap T) : pmap U :=
match m with
| Empty => Empty
| Branch h l r => Branch (fmap f h) (fmap_pmap l) (fmap_pmap r)
end.

Theorem fmap_lookup : forall a b m,
mapsto a b m ->
mapsto a (f b) (fmap_pmap m).
Proof. hammer_hook "FMapPositive" "FMapPositive.fmap_lookup".
induction a; destruct m; simpl; intros; try congruence.
{ eapply IHa. eapply H. }
{ eapply IHa; eapply H. }
{ subst. auto. }
Qed.

Theorem fmap_lookup_bk : forall a b m,
mapsto a b (fmap_pmap m) ->
exists b', mapsto a b' m /\ f b' = b.
Proof. hammer_hook "FMapPositive" "FMapPositive.fmap_lookup_bk".
induction a; destruct m; simpl; intros; try congruence.
{ eapply IHa. eapply H. }
{ eapply IHa. eapply H. }
{ destruct o; try congruence. eexists; split; eauto. inversion H; auto. }
Qed.

End fmap.

Require Import ExtLib.Core.Type.

Section type.
Variable T : Type.
Variable tT : type T.

Instance type_pmap : type (pmap T) :=
type_from_equal
(fun l r =>
(forall k v,
mapsto k v l -> exists v', mapsto k v' r /\ equal v v')
/\ (forall k v,
mapsto k v r -> exists v', mapsto k v' l /\ equal v v')).

End type.

Global Instance Functor_pmap : Functor pmap :=
{ fmap := fmap_pmap }.


(***
 * Oqarina
 * Copyright 2021 Carnegie Mellon University.
 *
 * NO WARRANTY. THIS CARNEGIE MELLON UNIVERSITY AND SOFTWARE ENGINEERING
 * INSTITUTE MATERIAL IS FURNISHED ON AN "AS-IS" BASIS. CARNEGIE MELLON
 * UNIVERSITY MAKES NO WARRANTIES OF ANY KIND, EITHER EXPRESSED OR
 * IMPLIED, AS TO ANY MATTER INCLUDING, BUT NOT LIMITED TO, WARRANTY OF
 * FITNESS FOR PURPOSE OR MERCHANTABILITY, EXCLUSIVITY, OR RESULTS
 * OBTAINED FROM USE OF THE MATERIAL. CARNEGIE MELLON UNIVERSITY DOES NOT
 * MAKE ANY WARRANTY OF ANY KIND WITH RESPECT TO FREEDOM FROM PATENT,
 * TRADEMARK, OR COPYRIGHT INFRINGEMENT.
 *
 * Released under a BSD (SEI)-style license, please see license.txt or
 * contact permission@sei.cmu.edu for full terms.
 *
 * [DISTRIBUTION STATEMENT A] This material has been approved for public
 * release and unlimited distribution.  Please see Copyright notice for
 * non-US Government use and distribution.
 *
 * This Software includes and/or makes use of the following Third-Party
 * Software subject to its own license:
 *
 * 1. Coq theorem prover (https://github.com/coq/coq/blob/master/LICENSE)
 * Copyright 2021 INRIA.
 *
 * 2. Coq JSON (https://github.com/liyishuai/coq-json/blob/comrade/LICENSE)
 * Copyright 2021 Yishuai Li.
 *
 * DM21-0762
***)

Require Import Coq.Lists.List.
Import ListNotations. (* from List *)

Require Import Oqarina.coq_utils.all.
Require Import Oqarina.core.all.
Import NaturalTime.
Require Import Oqarina.formalisms.DEVS.classic.all.
Require Import Oqarina.formalisms.lts.

Section Traffic_Light.

(*

Traffic Light example
=====================

In this section, we model the traffic light example from
:math:`\cite{vantendelooIntroductionClassicDEVS2018}`. This example is a direct transcription in Coq of the various types and functions definitions and yield no complexity. It is kept for testing and documentation purposes.

*)

Inductive X_tl :=
    | toAuto | toManual.

Inductive Y_tl :=
    | show_green | show_yellow | show_red | turn_off.

Inductive S_tl :=
    | GREEN | YELLOW | RED | GOING_MANUAL | GOING_AUTO | MANUAL.

Definition Q_tl : Type := Q S_tl.

Definition Q_init_tl : Q_tl := {| st := GREEN ; e := 0 |}.

Definition δint_tl (s : S_tl) : S_tl :=
    match s with
        | GREEN => YELLOW
        | YELLOW => RED
        | RED => GREEN
        | GOING_MANUAL => MANUAL
        | GOING_AUTO => RED
        | _ => s
    end.

Definition δext_tl (q : Q_tl) (x : X_tl) : S_tl :=
    match q.(st), x  with
        | GREEN,toManual => GOING_MANUAL
        | YELLOW, toManual => GOING_MANUAL
        | RED,toManual => GOING_MANUAL
        | MANUAL, toAuto => GOING_AUTO
        |  _, _ => q.(st)
    end.

Definition Y_output_tl : Type := Y_output Y_tl.

Definition λ_tl (s : S_tl) : Y_output_tl :=
    match s with
        | GREEN  => y show_yellow
        | YELLOW  => y show_red
        | RED  => y show_green
        | GOING_MANUAL  => y turn_off
        | GOING_AUTO  => y show_red
        | _ => no_output Y_tl
    end.

Definition ta_tl (s : S_tl) : Time :=
    match s with
        | GREEN  => 1
        | YELLOW  => 2
        | RED  => 3
        | GOING_MANUAL  => 0
        | GOING_AUTO  => 0
        | MANUAL => 10 (* infinity *)
    end.

(* From these specifications, we define the corresponding Coq data types.
First, a type representing the interface of a TrafficLight_Devs
(:coq:`TrafficLight_DEVS_Type`), then the DEVS atomic model itself.
*)

Definition TrafficLight_DEVS_type : Type := DEVS_Atomic_Model S_tl X_tl Y_tl.

Definition TrafficLight_DEVS : TrafficLight_DEVS_type := {|
    devs_atomic_id := (Id "TrafficLight");

    Q_init := Q_init_tl;

    ta := ta_tl;
    δint := δint_tl;
    λ := λ_tl ;
    δext := δext_tl;
|}.

(* Then, we instantiate the DEVS model to build on instance, or simulator. *)

Definition TrafficLight_DEVS_Simulator_type : Type :=
    DEVS_Simulator S_tl X_tl Y_tl.

Definition TL_Initial := Instantiate_DEVS_Simulator
    (Id "TrafficLighti") TrafficLight_DEVS.

(* From that point, we can simulate the Traffic Light. *)

Definition TL_Coordinator := Iniitialize_DEVS_Root_Coordinator TL_Initial.

Definition TLC_Step1 := DEVS_Simulation_Step TL_Coordinator None.
Lemma TLC_Step1_OK :
    (Print_DEVS_State TLC_Step1) = dbg 0 1 GREEN [].
Proof.
    trivial.
Qed.

Definition TLC_Step2 := DEVS_Simulation_Step TLC_Step1 None.
Lemma TLC_Step2_OK :
    (Print_DEVS_State TLC_Step2) = dbg 1 3 YELLOW [].
Proof.
    trivial.
Qed.

Definition TLC_Step3 := DEVS_Simulation_Step TLC_Step2 None.
Lemma TLC_Step3_OK :
    (Print_DEVS_State TLC_Step3) = dbg 3 6 RED [].
Proof.
    trivial.
Qed.

Definition TLC_Step4 := DEVS_Simulation_Step TLC_Step3 None.
Lemma TLC_Step4_OK :
    (Print_DEVS_State TLC_Step4) = dbg 6 7 GREEN [].
Proof.
    trivial.
Qed.

(* LTS variant of the Traffic LIght DEVS. We introduce a variant of the step
function that drops the output to compare the states with the previous
simulation run.*)

Definition TL_LTS := LTS_Of_DEVS TL_Initial.

Example TL_LTS_1 := step_lts (Init TL_LTS) (i X_tl Y_tl 0) .
Compute Print_DEVS_Simulator TL_LTS_1.

Lemma TL_LTS_1_OK :
    Print_DEVS_Simulator TL_LTS_1 = Print_DEVS_Simulator TLC_Step1.(astate).
Proof.
    trivial.
Qed.

End Traffic_Light.
(*| .. coq:: |*)

Section Traffic_Light_Coupled.
(*

Traffic Light couple example
============================

In this section, we build a naive coupled DEVS model out of the Traffic Light example. The coupled model is made of a single node. We use this as a first verification step that the coupled DEVS model made of one atonmic model has the same behavior.

*)

Definition Traffic_Light_Coupled := {|
    devs_coupled_model_id := Id "traffic_light_coupled" ;
    D := [ TL_Initial ] ;
    Select := @Default_Select_Function S_tl X_tl Y_tl ;
    Z_f :=  (fun (i : identifier) (y : Y_output_tl) => toManual) ;
    I := Default_I_Function;
|}.

Definition TL_coupled_atomic := Map_DEVS_Coupled_Model Traffic_Light_Coupled.

Definition TL_coupled_initial :=
    Instantiate_DEVS_Simulator (Id "traffic_light_coupled_instance")
    TL_coupled_atomic.

Definition TL_Coordinator_coupled := Iniitialize_DEVS_Root_Coordinator TL_coupled_initial.

Definition TLCC_Step1 := DEVS_Simulation_Step TL_Coordinator_coupled None.
Lemma TLCC_Step1_OK :
    (Print_DEVS_Simulator TLCC_Step1.(astate)) =
        dbg 0 1 [{| st := GREEN; e := 0 |}] [].
Proof.
    trivial.
Qed.

Definition TLCC_Step2 := DEVS_Simulation_Step TLCC_Step1 None.
Lemma TLCC_Step2_OK :
    (Print_DEVS_Simulator TLCC_Step2.(astate)) =
    dbg 1 3 [{| st := YELLOW; e := 0 |}] [].
Proof.
    trivial.
Qed.

Definition TLCC_Step3 := DEVS_Simulation_Step TLCC_Step2 None.
Lemma TLCC_Step3_OK :
    (Print_DEVS_Simulator TLCC_Step3.(astate)) =
    dbg 3 6 [{| st := RED; e := 0 |}] [].
Proof.
    trivial.
Qed.

Definition TLCC_Step4 := DEVS_Simulation_Step TLCC_Step3 None.
Lemma TLCC_Step4_OK :
    (Print_DEVS_Simulator TLCC_Step4.(astate)) =
    dbg 6 7 [{| st := GREEN; e := 0 |}] [].
Proof.
    trivial.
Qed.

End Traffic_Light_Coupled.
(*| .. coq:: |*)


Require Import floyd.proofauto.
Local Open Scope logic.
Require Import List. Import ListNotations.
Require Import ZArith.
Require Import tweetnacl20140427.tweetNaclBase.
Require Import tweetnacl20140427.Salsa20.
Require Import tweetnacl20140427.verif_salsa_base.
Require Import tweetnacl20140427.tweetnaclVerifiableC.
Require Import tweetnacl20140427.Snuffle.
Require Import tweetnacl20140427.spec_salsa.

Require Import tweetnacl20140427.verif_fcore_jbody.

Opaque Snuffle.Snuffle.

Lemma SnuffleS i l: Snuffle (S i) l = bind (Snuffle i l) (Snuffle 1). reflexivity. Qed.

Fixpoint WcontI (xs: list int) (j:nat) (l:list val):Prop :=
   match j with O => Zlength l = 16
   | (S n) => Zlength l = 16 /\
              exists t0 t1 t2 t3,
              Znth ((5 * (Z.of_nat n) + 4 * 0) mod 16) (map Vint xs) Vundef = Vint t0 /\
              Znth ((5 * (Z.of_nat n) + 4 * 1) mod 16) (map Vint xs) Vundef = Vint t1 /\
              Znth ((5 * (Z.of_nat n) + 4 * 2) mod 16) (map Vint xs) Vundef = Vint t2 /\
              Znth ((5 * (Z.of_nat n) + 4 * 3) mod 16) (map Vint xs) Vundef = Vint t3 /\
              exists wl, WcontI xs n wl /\
                match Wcopyspec t0 t1 t2 t3 with
                 (s0,s1,s2,s3) => wlistJ' wl (Z.of_nat n) s0 s1 s2 s3 l
                end
  end.

Lemma WcontI_Zlength xs j l: WcontI xs j l -> Zlength l=16.
Proof. intros. destruct j; eapply H. Qed.

Lemma WWI r w (W: WcontI r 4 w) (R:Zlength r = 16):
      exists wi, w=map Vint wi /\ snuffleRound r = Some wi.
Proof.
apply listD16 in R.
destruct R as [x0 [x1 [x2 [x3 [x4 [x5 [x6 [x7
              [x8 [x9 [x10 [x11 [x12 [x13 [x14 [x15 XX]]]]]]]]]]]]]]]]. subst r.
destruct W as [HW H1].
destruct H1 as [t0 [t1 [t2 [t3 [T0 [T1 [T2 [T3 [w1 [[_ H1] W1]]]]]]]]]]. simpl in T0, T1, T2, T3.
rewrite Z.mod_small in T0. 2: omega.
rewrite Zmod_eq in T1. 2: omega.
rewrite Zmod_eq in T2. 2: omega.
rewrite Zmod_eq in T3. 2: omega. simpl in T0, T1, T2, T3.
destruct H1 as [t4 [t5 [t6 [t7 [T4 [T5 [T6 [T7 [w2 [[_ H1] W2]]]]]]]]]]. simpl in T4, T5, T6, T7.
rewrite Zmod_eq in T4. 2: omega.
rewrite Zmod_eq in T5. 2: omega.
rewrite Zmod_eq in T6. 2: omega.
rewrite Zmod_eq in T7. 2: omega. simpl in T4, T5, T6, T7.
destruct H1 as [t8 [t9 [t10 [t11 [T8 [T9 [T10 [T11 [w3 [[_ H1] W3]]]]]]]]]]. simpl in T8, T9, T10, T11.
rewrite Z.mod_small in T8. 2: omega.
rewrite Z.mod_small in T9. 2: omega.
rewrite Zmod_eq in T10. 2: omega.
rewrite Zmod_eq in T11. 2: omega. simpl in T8, T9, T10, T11.
destruct H1 as [t12 [t13 [t14 [t15 [T12 [T13 [T14 [T15 [w4 [L4 W4]]]]]]]]]]. simpl in T12, T13, T14, T15.
rewrite Z.mod_small in T12. 2: omega.
rewrite Z.mod_small in T13. 2: omega.
rewrite Z.mod_small in T14. 2: omega.
rewrite Z.mod_small in T15. 2: omega.
unfold Znth in *. simpl in  T0, T1, T2, T3, T4, T5, T6, T7, T8, T9, T10, T11, T12, T13, T14, T15.
symmetry in T0; inv T0. symmetry in T1; inv T1. symmetry in T2; inv T2. symmetry in T3; inv T3.
symmetry in T4; inv T4. symmetry in T5; inv T5. symmetry in T6; inv T6. symmetry in T7; inv T7.
symmetry in T8; inv T8. symmetry in T9; inv T9. symmetry in T10; inv T10. symmetry in T11; inv T11.
symmetry in T12; inv T12. symmetry in T13; inv T13. symmetry in T14; inv T14. symmetry in T15; inv T15.
red in L4.
simpl in W4.
remember (Int.xor x4 (Int.rol (Int.add x0 x12) (Int.repr 7))) as z1.
remember (Int.xor x8 (Int.rol (Int.add z1 x0) (Int.repr 9))) as z2.
remember (Int.xor x12 (Int.rol (Int.add z2 z1) (Int.repr 13))) as z3.
remember (Int.xor x0 (Int.rol (Int.add z3 z2) (Int.repr 18))) as z0.
apply listD16 in L4.
destruct L4 as [y0 [y1 [y2 [y3 [y4 [y5 [y6 [y7
               [y8 [y9 [y10 [y11 [y12 [y13 [y14 [y15 XX]]]]]]]]]]]]]]]]. subst w4.
destruct W4 as [_ W4]; simpl in W4.
(*rewrite Z.mod_small in W4. 2: omega.
rewrite Z.mod_small in W4. 2: omega.
rewrite Z.mod_small in W4. 2: omega.
rewrite Z.mod_small in W4. 2: omega.*)
unfold upd_Znth, sublist in W4; simpl in W4. subst w3.
simpl in W3.
remember (Int.xor x9 (Int.rol (Int.add x5 x1) (Int.repr 7))) as z6.
remember (Int.xor x13 (Int.rol (Int.add z6 x5) (Int.repr 9))) as z7.
remember (Int.xor x1 (Int.rol (Int.add z7 z6) (Int.repr 13))) as z4.
remember (Int.xor x5 (Int.rol (Int.add z4 z7) (Int.repr 18))) as z5.
destruct W3 as [_ W3]; simpl in W3.
unfold upd_Znth, sublist in W3; simpl in W3. subst w2.
destruct W2 as [_ W2]. simpl in W2.
remember (Int.xor x14 (Int.rol (Int.add x10 x6) (Int.repr 7))) as z11.
remember (Int.xor x2 (Int.rol (Int.add z11 x10) (Int.repr 9))) as z8.
remember (Int.xor x6 (Int.rol (Int.add z8 z11) (Int.repr 13))) as z9.
remember (Int.xor x10 (Int.rol (Int.add z9 z8) (Int.repr 18))) as z10.
unfold upd_Znth, sublist in W2; simpl in W2. subst w1.
destruct W1 as [_ W1]; simpl in W1.
remember (Int.xor x3 (Int.rol (Int.add x15 x11) (Int.repr 7))) as z12.
remember (Int.xor x7 (Int.rol (Int.add z12 x15) (Int.repr 9))) as z13.
remember (Int.xor x11 (Int.rol (Int.add z13 z12) (Int.repr 13))) as z14.
remember (Int.xor x15 (Int.rol (Int.add z14 z13) (Int.repr 18))) as z15.
unfold upd_Znth, sublist in W1; simpl in W1. subst w. clear HW.
exists [z0; z1; z2; z3; z4; z5; z6; z7;
        z8; z9; z10; z11; z12; z13; z14; z15].
split. reflexivity.
rewrite Int.add_commut in Heqz0, Heqz2, Heqz3, Heqz4, Heqz5, Heqz7, Heqz8,
  Heqz9, Heqz10, Heqz13, Heqz14, Heqz15.
subst z0 z1 z2 z3 z4 z5 z6 z7 z8 z9 z10 z11 z12 z13 z14 z15. reflexivity.
Qed.

Lemma array_copy3 Espec:
forall FR c k h nonce out
       i w x y t (xlist wlist:list val)
       (WZ: forall m, 0<=m<16 -> exists mval, Znth m wlist Vundef =Vint mval),
@semax CompSpecs Espec
  (initialized_list [_i; _j]
     (func_tycontext f_core SalsaVarSpecs SalsaFunSpecs))
  (PROP  ()
   LOCAL  (temp _j (Vint (Int.repr 4)); temp _i (Vint (Int.repr i)); lvar _t (tarray tuint 4) t;
   lvar _y (tarray tuint 16) y; lvar _x (tarray tuint 16) x;
   lvar _w (tarray tuint 16) w; temp _in nonce; temp _out out; temp _c c;
   temp _k k; temp _h (Vint (Int.repr h)))
   SEP  (FR; data_at Tsh (tarray tuint 16) wlist w;
         data_at Tsh (tarray tuint 16) xlist x))
  (Sfor (Sset _m (Econst_int (Int.repr 0) tint))
     (Ebinop Olt (Etempvar _m tint) (Econst_int (Int.repr 16) tint) tint)
     (Ssequence
        (Sset _aux
           (Ederef
              (Ebinop Oadd (Evar _w (tarray tuint 16)) (Etempvar _m tint)
                 (tptr tuint)) tuint))
        (Sassign
           (Ederef
              (Ebinop Oadd (Evar _x (tarray tuint 16)) (Etempvar _m tint)
                 (tptr tuint)) tuint) (Etempvar _aux tuint)))
     (Sset _m
        (Ebinop Oadd (Etempvar _m tint) (Econst_int (Int.repr 1) tint) tint)))
  (normal_ret_assert
  (PROP  ()
   LOCAL  (temp _j (Vint (Int.repr 4)); temp _i (Vint (Int.repr i)); lvar _t (tarray tuint 4) t;
      lvar _y (tarray tuint 16) y; lvar _x (tarray tuint 16) x;
      lvar _w (tarray tuint 16) w; temp _in nonce; temp _out out; temp _c c;
      temp _k k; temp _h (Vint (Int.repr h)))
   SEP  (FR; data_at Tsh (tarray tuint 16) wlist w;
         data_at Tsh (tarray tuint 16) wlist x))).
Proof. intros. abbreviate_semax.
Time assert_PROP (Zlength wlist = 16 /\ Zlength xlist = 16) as WXL by entailer!. (*1.4 versus 5.4*)
destruct WXL as [WL XL].
Time forward_for_simple_bound 16 (EX m:Z,
  (PROP  ()
   LOCAL  (temp _j (Vint (Int.repr 4)); temp _i (Vint (Int.repr i)); lvar _t (tarray tuint 4) t;
   lvar _y (tarray tuint 16) y; lvar _x (tarray tuint 16) x;
   lvar _w (tarray tuint 16) w; temp _in nonce; temp _out out; temp _c c;
   temp _k k; temp _h (Vint (Int.repr h)))
   SEP  (FR; data_at Tsh (tarray tuint 16) wlist w;
         EX mlist:_, !!(forall mm, 0<=mm<m -> Znth mm mlist Vundef = Znth mm wlist Vundef)
                && data_at Tsh (tarray tuint 16) mlist x))).
  (*1.2 versus 2.7*)
{ Exists xlist. Time entailer!. (*2.6 versus 6.7*) intros; omega. }
{ Intros mlist. rename H into M. rename i0 into m. rename H0 into HM.
  destruct (WZ _ M) as [mval MVAL].
  freeze [0;2] FR1.
  Time forward; rewrite MVAL. (*3.5 versus 8.7*)
  Time solve[entailer!]. (*0.9 versus 3.3*)
  thaw FR1.
  Time assert_PROP (Zlength mlist = 16) as ML by entailer!. (*1.2 versus 3.5*)
  Time forward. (*3.2 versus 9*)
   { Exists (upd_Znth m mlist (Vint mval)).
     Time entailer!. (*2.8 versus 5.6*)
     intros mm ?.
     destruct (zeq mm m); subst.
     + rewrite MVAL, upd_Znth_same; trivial. omega.
     + rewrite <- HM. 2: omega.
       apply upd_Znth_diff; trivial; omega. }
}
{ Time entailer!. (*1.8 versus 4.3*)
  Intros mlist.
  assert_PROP (Zlength mlist = 16) as ML by entailer.
  apply derives_refl'. f_equal.
  eapply Znth_extensional with (d:=Vundef). omega.
  intros kk K. apply H1. omega. }
Time Qed. (*16.8*)

Lemma f_core_loop3: forall (Espec : OracleKind) FR
c k h nonce out w x y t (xI:list int),
@semax CompSpecs Espec
  (initialized_list [_i] (func_tycontext f_core SalsaVarSpecs SalsaFunSpecs))
  (PROP  ()
   LOCAL  (temp _i (Vint (Int.repr 16)); lvar _t (tarray tuint 4) t;
   lvar _y (tarray tuint 16) y; lvar _x (tarray tuint 16) x;
   lvar _w (tarray tuint 16) w; temp _in nonce; temp _out out; temp _c c;
   temp _k k; temp _h (Vint (Int.repr h)))
   SEP  (FR; data_at_ Tsh (tarray tuint 4) t;
         data_at_ Tsh (tarray tuint 16) w;
         data_at Tsh (tarray tuint 16) (map Vint xI) x))
         (Sfor (Sset _i (Econst_int (Int.repr 0) tint))
            (Ebinop Olt (Etempvar _i tint) (Econst_int (Int.repr 20) tint) tint)
            (Ssequence
               (Sfor (Sset _j (Econst_int (Int.repr 0) tint))
                  (Ebinop Olt (Etempvar _j tint) (Econst_int (Int.repr 4) tint) tint)
                  (Ssequence
                     (Sfor (Sset _m (Econst_int (Int.repr 0) tint))
                        (Ebinop Olt (Etempvar _m tint) (Econst_int (Int.repr 4) tint) tint)
                        (Ssequence
                           (Sset _index
                              (Ebinop Omod
                                 (Ebinop Oadd
                                    (Ebinop Omul (Econst_int (Int.repr 5) tint)
                                       (Etempvar _j tint) tint)
                                    (Ebinop Omul (Econst_int (Int.repr 4) tint)
                                       (Etempvar _m tint) tint) tint) (Econst_int (Int.repr 16) tint)
                                 tint))
                           (Ssequence
                              (Sset _aux
                                 (Ederef
                                    (Ebinop Oadd (Evar _x (tarray tuint 16))
                                       (Etempvar _index tint) (tptr tuint)) tuint))
                              (Sassign
                                 (Ederef
                                    (Ebinop Oadd (Evar _t (tarray tuint 4))
                                       (Etempvar _m tint) (tptr tuint)) tuint)
                                 (Etempvar _aux tuint))))
                        (Sset _m (Ebinop Oadd (Etempvar _m tint) (Econst_int (Int.repr 1) tint) tint)))
                     (Ssequence
                        (Ssequence
                           (Sset _aux
                              (Ederef
                                 (Ebinop Oadd (Evar _t (tarray tuint 4))
                                    (Econst_int (Int.repr 0) tint) (tptr tuint)) tuint))
                           (Ssequence
                              (Sset _aux1
                                 (Ederef
                                    (Ebinop Oadd (Evar _t (tarray tuint 4))
                                       (Econst_int (Int.repr 3) tint) (tptr tuint)) tuint))
                              (Ssequence
                                 (Sset _aux
                                    (Ebinop Oadd (Etempvar _aux tuint) (Etempvar _aux1 tuint) tuint))
                                 (Ssequence
                                    (Ssequence
                                       (Scall (Some _t'5)
                                          (Evar _L32
                                             (Tfunction (Tcons tuint (Tcons tint Tnil)) tuint
                                                cc_default))
                                          [Etempvar _aux tuint; Econst_int (Int.repr 7) tint])
                                       (Sset _aux (Etempvar _t'5 tuint)))
                                    (Ssequence
                                       (Sset _aux1
                                          (Ederef
                                             (Ebinop Oadd (Evar _t (tarray tuint 4))
                                                (Econst_int (Int.repr 1) tint)
                                                (tptr tuint)) tuint))
                                       (Ssequence
                                          (Sset _aux1
                                             (Ebinop Oxor (Etempvar _aux1 tuint)
                                                (Etempvar _aux tuint) tuint))
                                          (Sassign
                                             (Ederef
                                                (Ebinop Oadd (Evar _t (tarray tuint 4))
                                                   (Econst_int (Int.repr 1) tint)
                                                   (tptr tuint)) tuint) (Etempvar _aux1 tuint))))))))
                        (Ssequence
                           (Ssequence
                              (Sset _aux
                                 (Ederef
                                    (Ebinop Oadd (Evar _t (tarray tuint 4))
                                       (Econst_int (Int.repr 1) tint) (tptr tuint)) tuint))
                              (Ssequence
                                 (Sset _aux1
                                    (Ederef
                                       (Ebinop Oadd (Evar _t (tarray tuint 4))
                                          (Econst_int (Int.repr 0) tint)
                                          (tptr tuint)) tuint))
                                 (Ssequence
                                    (Sset _aux
                                       (Ebinop Oadd (Etempvar _aux tuint)
                                          (Etempvar _aux1 tuint) tuint))
                                    (Ssequence
                                       (Ssequence
                                          (Scall (Some _t'6)
                                             (Evar _L32
                                                (Tfunction (Tcons tuint (Tcons tint Tnil)) tuint
                                                   cc_default))
                                             [Etempvar _aux tuint; Econst_int (Int.repr 9) tint])
                                          (Sset _aux (Etempvar _t'6 tuint)))
                                       (Ssequence
                                          (Sset _aux1
                                             (Ederef
                                                (Ebinop Oadd (Evar _t (tarray tuint 4))
                                                   (Econst_int (Int.repr 2) tint)
                                                   (tptr tuint)) tuint))
                                          (Ssequence
                                             (Sset _aux1
                                                (Ebinop Oxor (Etempvar _aux1 tuint)
                                                   (Etempvar _aux tuint) tuint))
                                             (Sassign
                                                (Ederef
                                                   (Ebinop Oadd (Evar _t (tarray tuint 4))
                                                      (Econst_int (Int.repr 2) tint)
                                                      (tptr tuint)) tuint)
                                                (Etempvar _aux1 tuint))))))))
                           (Ssequence
                              (Ssequence
                                 (Sset _aux
                                    (Ederef
                                       (Ebinop Oadd (Evar _t (tarray tuint 4))
                                          (Econst_int (Int.repr 2) tint)
                                          (tptr tuint)) tuint))
                                 (Ssequence
                                    (Sset _aux1
                                       (Ederef
                                          (Ebinop Oadd (Evar _t (tarray tuint 4))
                                             (Econst_int (Int.repr 1) tint)
                                             (tptr tuint)) tuint))
                                    (Ssequence
                                       (Sset _aux
                                          (Ebinop Oadd (Etempvar _aux tuint)
                                             (Etempvar _aux1 tuint) tuint))
                                       (Ssequence
                                          (Ssequence
                                             (Scall (Some _t'7)
                                                (Evar _L32
                                                   (Tfunction (Tcons tuint (Tcons tint Tnil)) tuint
                                                      cc_default))
                                                [Etempvar _aux tuint; Econst_int (Int.repr 13) tint])
                                             (Sset _aux (Etempvar _t'7 tuint)))
                                          (Ssequence
                                             (Sset _aux1
                                                (Ederef
                                                   (Ebinop Oadd (Evar _t (tarray tuint 4))
                                                      (Econst_int (Int.repr 3) tint)
                                                      (tptr tuint)) tuint))
                                             (Ssequence
                                                (Sset _aux1
                                                   (Ebinop Oxor (Etempvar _aux1 tuint)
                                                      (Etempvar _aux tuint) tuint))
                                                (Sassign
                                                   (Ederef
                                                      (Ebinop Oadd (Evar _t (tarray tuint 4))
                                                         (Econst_int (Int.repr 3) tint)
                                                         (tptr tuint)) tuint)
                                                   (Etempvar _aux1 tuint))))))))
                              (Ssequence
                                 (Ssequence
                                    (Sset _aux
                                       (Ederef
                                          (Ebinop Oadd (Evar _t (tarray tuint 4))
                                             (Econst_int (Int.repr 3) tint)
                                             (tptr tuint)) tuint))
                                    (Ssequence
                                       (Sset _aux1
                                          (Ederef
                                             (Ebinop Oadd (Evar _t (tarray tuint 4))
                                                (Econst_int (Int.repr 2) tint)
                                                (tptr tuint)) tuint))
                                       (Ssequence
                                          (Sset _aux
                                             (Ebinop Oadd (Etempvar _aux tuint)
                                                (Etempvar _aux1 tuint) tuint))
                                          (Ssequence
                                             (Ssequence
                                                (Scall (Some _t'8)
                                                   (Evar _L32
                                                      (Tfunction (Tcons tuint (Tcons tint Tnil))
                                                         tuint cc_default))
                                                   [Etempvar _aux tuint;
                                                   Econst_int (Int.repr 18) tint])
                                                (Sset _aux (Etempvar _t'8 tuint)))
                                             (Ssequence
                                                (Sset _aux1
                                                   (Ederef
                                                      (Ebinop Oadd (Evar _t (tarray tuint 4))
                                                         (Econst_int (Int.repr 0) tint)
                                                         (tptr tuint)) tuint))
                                                (Ssequence
                                                   (Sset _aux1
                                                      (Ebinop Oxor (Etempvar _aux1 tuint)
                                                         (Etempvar _aux tuint) tuint))
                                                   (Sassign
                                                      (Ederef
                                                         (Ebinop Oadd (Evar _t (tarray tuint 4))
                                                            (Econst_int (Int.repr 0) tint)
                                                            (tptr tuint)) tuint)
                                                      (Etempvar _aux1 tuint))))))))
                                 (Sfor (Sset _m (Econst_int (Int.repr 0) tint))
                                    (Ebinop Olt (Etempvar _m tint) (Econst_int (Int.repr 4) tint)
                                       tint)
                                    (Ssequence
                                       (Sset _aux
                                          (Ederef
                                             (Ebinop Oadd (Evar _t (tarray tuint 4))
                                                (Etempvar _m tint) (tptr tuint)) tuint))
                                       (Ssequence
                                          (Sset _aux1
                                             (Ebinop Oadd
                                                (Ebinop Omul (Econst_int (Int.repr 4) tint)
                                                   (Etempvar _j tint) tint)
                                                (Ebinop Omod
                                                   (Ebinop Oadd (Etempvar _j tint)
                                                      (Etempvar _m tint) tint)
                                                   (Econst_int (Int.repr 4) tint) tint) tint))
                                          (Sassign
                                             (Ederef
                                                (Ebinop Oadd (Evar _w (tarray tuint 16))
                                                   (Etempvar _aux1 tuint)
                                                   (tptr tuint)) tuint) (Etempvar _aux tuint))))
                                    (Sset _m
                                       (Ebinop Oadd (Etempvar _m tint) (Econst_int (Int.repr 1) tint)
                                          tint))))))))
                  (Sset _j (Ebinop Oadd (Etempvar _j tint) (Econst_int (Int.repr 1) tint) tint)))
               (Sfor (Sset _m (Econst_int (Int.repr 0) tint))
                  (Ebinop Olt (Etempvar _m tint) (Econst_int (Int.repr 16) tint) tint)
                  (Ssequence
                     (Sset _aux
                        (Ederef
                           (Ebinop Oadd (Evar _w (tarray tuint 16)) (Etempvar _m tint) (tptr tuint))
                           tuint))
                     (Sassign
                        (Ederef
                           (Ebinop Oadd (Evar _x (tarray tuint 16)) (Etempvar _m tint) (tptr tuint))
                           tuint) (Etempvar _aux tuint)))
                  (Sset _m (Ebinop Oadd (Etempvar _m tint) (Econst_int (Int.repr 1) tint) tint))))
            (Sset _i (Ebinop Oadd (Etempvar _i tint) (Econst_int (Int.repr 1) tint) tint)))

  (normal_ret_assert
  (PROP  ()
   LOCAL  (temp _i (Vint (Int.repr 20)); lvar _t (tarray tuint 4) t; lvar _y (tarray tuint 16) y;
       lvar _x (tarray tuint 16) x; lvar _w (tarray tuint 16) w; temp _in nonce;
       temp _out out; temp _c c; temp _k k; temp _h (Vint (Int.repr h)))
   SEP (FR; data_at_ Tsh (tarray tuint 4) t; data_at_ Tsh (tarray tuint 16) w;
        EX r:_, !!(Snuffle 20 xI = Some r) &&
           data_at Tsh (tarray tuint 16) (map Vint r) x))).
Proof. intros. abbreviate_semax.
freeze [0;1;2] FR1.
Time assert_PROP (Zlength (map Vint xI) = 16) as XIZ by entailer!. (*0.9*)
thaw FR1.
rewrite Zlength_map in XIZ.
drop_LOCAL 0%nat.
Time forward_for_simple_bound 20 (EX i:Z,
  (PROP  ()
   LOCAL  (lvar _t (tarray tuint 4) t;
   lvar _y (tarray tuint 16) y; lvar _x (tarray tuint 16) x;
   lvar _w (tarray tuint 16) w; temp _in nonce; temp _out out; temp _c c;
   temp _k k; temp _h (Vint (Int.repr h)))
   SEP  (FR; data_at_ Tsh (tarray tuint 4) t; data_at_ Tsh (tarray tuint 16) w;
         EX r:_, !!(Snuffle (Z.to_nat i) xI = Some r) &&
             data_at Tsh (tarray tuint 16) (map Vint r) x))). (*0.9*)
{ Exists xI. Time entailer!. (*2.6*) }

{ rename H into I. Intros r. rename H into R.
  assert (XI: length xI = 16%nat). eapply (Zlength_length _ _ 16). omega. trivial.
  assert (RL:= Snuffle_length _ _ _ R XI).
  assert (RZL: Zlength r = 16). rewrite Zlength_correct, RL; reflexivity.

  Time forward_for_simple_bound 4 (EX j:Z,
  (PROP  ()
   LOCAL  (temp _i (Vint (Int.repr i)); lvar _t (tarray tuint 4) t;
   lvar _y (tarray tuint 16) y; lvar _x (tarray tuint 16) x;
   lvar _w (tarray tuint 16) w; temp _in nonce; temp _out out; temp _c c;
   temp _k k; temp _h (Vint (Int.repr h)))
   SEP  (FR; data_at_ Tsh (tarray tuint 4) t;
      EX l:_, !!(WcontI r (Z.to_nat j) l) && data_at Tsh (tarray tuint 16) l w;
      data_at Tsh (tarray tuint 16) (map Vint r) x))). (*1.5*)
  { Time entailer!. (*2.5*) Exists (list_repeat 16 Vundef). Time entailer!. (*0.1*) }
  { rename H into J. rename i0 into j.
    Intros wlist. rename H into WCONT.
    destruct (Znth_mapVint r ((5 * j + 4 * 0) mod 16) Vundef) as [t0 T0].
      rewrite RZL; apply Z_mod_lt; omega.
    destruct (Znth_mapVint r ((5 * j + 4 * 1) mod 16) Vundef) as [t1 T1].
      rewrite RZL; apply Z_mod_lt; omega.
    destruct (Znth_mapVint r ((5 * j + 4 * 2) mod 16) Vundef) as [t2 T2].
      rewrite RZL; apply Z_mod_lt; omega.
    destruct (Znth_mapVint r ((5 * j + 4 * 3) mod 16) Vundef) as [t3 T3].
      rewrite RZL; apply Z_mod_lt; omega.
    eapply semax_post.
    2: apply (Jbody _ FR c k h nonce out w x y t i j r I J wlist _ _ _ _ T0 T1 T2 T3).
    intros; apply andp_left2.
    unfold POSTCONDITION, abbreviate.
    apply assert_lemmas.normal_ret_assert_derives'.
    Intros W. Exists W. old_go_lower. Time entailer!. (*6.1*) (*TODO: eliminate old_go_lower*)
    rewrite Z.add_comm, Z2Nat.inj_add; try omega.
    assert (X: (Z.to_nat 1 + Z.to_nat j = S (Z.to_nat j))%nat) by reflexivity.
    rewrite X. simpl. split. assumption.
    exists t0, t1, t2, t3. simpl in T0, T1, T2, T3. rewrite Z2Nat.id, T0, T1, T2, T3.
    repeat split; trivial.
    exists wlist. split; trivial. omega. }

  Intros wlist. rename H into HW.
  destruct (WWI _ _ HW RZL) as [wints [WI SNUFF]]. subst wlist.
  freeze [0;1] FR2.
  eapply semax_post.
  Focus 2. apply (array_copy3 _ (FRZL FR2) c k h nonce out
                  i w x y t (map Vint r) (map Vint wints)); trivial.
           intros. apply Znth_mapVint.
              destruct (snuffleRound_length _ _ SNUFF) as [WL _].
              rewrite Zlength_correct, WL; simpl; omega.
  intros ? ?. apply andp_left2.
    unfold POSTCONDITION, abbreviate.
    apply assert_lemmas.normal_ret_assert_derives'.
  Exists wints. rewrite Z.add_comm, Z2Nat.inj_add; try omega.
  old_go_lower. Time entailer!. (*4.3*)(*TODO: eliminate old_go_lower*)
  rewrite SnuffleS, R; trivial.
  thaw FR2; cancel. }
apply andp_left2; apply derives_refl.
Time Qed. (*11.891 secs (3.562u,0.s) (successful)*)