(* Computational definition and declarative spec for closure conversion. Part of the CertiCoq project.
 * Author: Zoe Paraskevopoulou, 2016
 *)

From SFS Require Import cps cps_util set_util identifiers ctx
     Ensembles_util List_util functions.

From Coq Require Import ZArith.Znumtheory
     Lists.List MSets.MSets MSets.MSetRBT Numbers.BinNums
     NArith.BinNat PArith.BinPos Sets.Ensembles Strings.String.

From ExtLib Require Import Structures.Monads Data.Monads.StateMonad.
From Template Require Import BasicAst. (* For identifier names *)

Import ListNotations Nnat MonadNotation.

From SFS Require Import Coqlib Maps.

Open Scope monad_scope.
Open Scope ctx_scope.
Open Scope fun_scope.
Open Scope string.

(** * Closure conversion as a relation  *)

Section CC.

  Variable (clo_tag : cTag). (* Tag for closure records *)

  (* The free-variable set of a source program *)
  Definition FV (Scope : Ensemble var) (Funs : Ensemble var) (FVs : list var) :=
    Scope :|: (Funs \\ Scope) :|: (FromList FVs \\ (Scope :|: Funs)).

  (* The free-variable set of a closure converted *)
  Definition FV_cc (Scope : Ensemble var) (Funs : Ensemble var) (γ : var  -> var) (Γ : var) :=
    Scope :|: (Funs \\ Scope) :|: image γ (Funs \\ Scope) :|: [set Γ].

  (* Closure application *)
  Definition AppClo f t xs f' Γ :=
    Eproj f' clo_tag 0%N f
          (Eproj Γ clo_tag 1%N f
                 (Eapp f' t (Γ :: xs))).

  Inductive project_var :
    Ensemble var -> (* Variables in the current scope *)
    Ensemble var -> (* Functions not yet constructed *)
    (var -> var) -> (* function mapping functions to environments *)
    cTag -> (* tag of the current environment constructor *)
    var -> (* Current environment *)
    list var -> (* The environment *)
    var -> (* Before projection *)
    exp_ctx -> (* Context that will perform the projection *)
    Ensemble var -> (* New current scope *)
    Ensemble var -> (* New funs *)
    Prop :=
  | Var_in_Scope :
      forall Scope Funs fenv c FVs x Γ,
        x \in Scope ->
        project_var Scope Funs fenv c Γ FVs x Hole_c Scope Funs
  | Var_in_Funs :
      forall Scope Funs fenv c FVs f Γ,
        ~ f \in Scope ->
        f \in Funs ->
        (* adds the function in scope so that it's not constructed again *)
        project_var Scope Funs fenv c Γ FVs f
                    (Econstr_c f clo_tag [f ; (fenv f)] Hole_c) (f |: Scope) (Funs \\ [set f])
  | Var_in_FVs :
      forall Scope Funs fenv c FVs x N Γ,
        ~ x \in Scope ->
        ~ x \in Funs ->
        nthN FVs N = Some x ->
        (* adds the var in scope so that it's not projected again *)
        project_var Scope Funs fenv c Γ FVs x
                    (Eproj_c x c N Γ Hole_c) (x |: Scope) Funs.

  Inductive project_vars :
    Ensemble var -> (* Variables in the current scope *)
    Ensemble var -> (* Functions not yet constructed *)
    (var -> var) -> (* function mapping functions to environments *)
    cTag -> (* tag of the current environment constructor *)
    var -> (* The environment argument *)
    list var -> (* The free variables *)
    list var -> (* Before projection *)
    exp_ctx -> (* Context that will perform the projection *)
    Ensemble var -> (* New current scope *)
    Ensemble var -> (* Funs *)
    Prop :=
  | VarsNil :
      forall Scope Funs fenv c Γ FVs,
        project_vars Scope Funs fenv c Γ FVs [] Hole_c Scope Funs
  | VarsCons :
      forall Scope1 Scope2 Scope3 Funs1 Funs2 Funs3 fenv c Γ FVs y ys C1 C2,
        project_var Scope1 Funs1 fenv c Γ FVs y C1 Scope2 Funs2 ->
        project_vars Scope2 Funs2 fenv c Γ FVs ys C2 Scope3 Funs3  ->
        project_vars Scope1 Funs1 fenv c Γ FVs (y :: ys) (comp_ctx_f C1 C2) Scope3 Funs3.

  Definition extend_fundefs' (f : var -> var) (B : fundefs) (x : var) : var -> var :=
    fun y => if (@Dec _ (name_in_fundefs B) _) y then x else f y.

  Inductive Closure_conversion :
    Ensemble var -> (* Variables in the current scope *)
    Ensemble var -> (* Functions that are not yet constructed *)
    (var -> var) -> (* function mapping functions to environments *)
    cTag -> (* tag of the current environment constructor *)
    var -> (* The environment argument *)
    list var -> (* The free variables - need to be ordered *)
    exp -> (* Before cc *)
    exp -> (* After cc *)
    exp_ctx -> (* The context that the output expression should be put in *)
    Prop :=
  | CC_Econstr :
      forall Scope Scope' Funs Funs' fenv c Γ FVs x ys C C' t e e',
        project_vars Scope Funs fenv c Γ FVs ys C Scope' Funs' ->
        Closure_conversion (x |: Scope') Funs' fenv c Γ FVs e e' C' ->
        Closure_conversion Scope Funs fenv c Γ FVs (Econstr x t ys e)
                           (Econstr x t ys (C' |[ e' ]|)) C
  | CC_Ecase :
      forall Scope Scope' Funs Funs' fenv c Γ FVs x C pats pats',
        project_var Scope Funs fenv c Γ FVs x C Scope' Funs' ->
        Forall2 (fun (pat pat' : cTag * exp) =>
                   (fst pat) = (fst pat') /\
                   exists C' e',
                     snd pat' = C' |[ e' ]| /\
                     Closure_conversion Scope' Funs' fenv c Γ FVs (snd pat) e' C')
                pats pats' ->
        Closure_conversion Scope Funs fenv c Γ FVs (Ecase x pats) (Ecase x pats') C
  | CC_Eproj :
      forall Scope Scope' Funs Funs' fenv c Γ FVs x y C C' t N e e',
        project_var Scope Funs fenv c Γ FVs y C Scope' Funs' ->
        Closure_conversion (x |: Scope') Funs' fenv c Γ FVs e e' C' ->
        Closure_conversion Scope Funs fenv c Γ FVs (Eproj x t N y e)
                           (Eproj x t N y (C' |[ e' ]|)) C
  | CC_Efun :
      forall Scope Scope' Funs Funs' fenv c Γ c' Γ' FVs FVs' B B' e e' C Ce,
        (* The environment contains all the variables that are free in B *)
        (occurs_free_fundefs B) <--> (FromList FVs') ->
        (* needed for cost preservation *)
        NoDup FVs' ->
        project_vars Scope Funs fenv c Γ FVs FVs' C Scope' Funs' ->
        (* Γ' is the variable that will hold the record of the environment *)
        ~ Γ' \in (bound_var (Efun B e) :|: FromList FVs' :|: FV Scope Funs FVs :|:
                  FV_cc Scope Funs fenv Γ) ->
        (* closure convert function blocks *)
        Closure_conversion_fundefs B c' FVs' B B' ->
        (* closure convert the rest of the program *)
        Closure_conversion (Scope' \\ name_in_fundefs B)
                           ((name_in_fundefs B) :|: Funs') (extend_fundefs' fenv B Γ') c Γ FVs e e' Ce  ->
        Closure_conversion Scope Funs fenv c Γ FVs (Efun B e)
                           (Efun B' (Ce |[ e' ]|)) (comp_ctx_f C (Econstr_c Γ' c' FVs' Hole_c))
  | CC_Eapp :
      forall Scope Scope' Funs Funs' fenv c Γ FVs f f' ft env' ys C S,
        Disjoint _ S (FV_cc Scope' Funs' fenv Γ) ->
        (* Project the function name and the actual parameter *)
        project_vars Scope Funs fenv c Γ FVs (f :: ys) C Scope' Funs' ->
        (* The name of the function pointer and the name of the environment
         should not shadow the variables in the current scope and the
         variables that where used in the projections *)
        f' \in S -> env' \in S -> f' <> env' ->
        Closure_conversion Scope Funs fenv c Γ FVs (Eapp f ft ys) (AppClo f ft ys f' env') C
  | CC_Eprim :
      forall Scope Scope' Funs Funs' fenv c Γ FVs x ys C C' f e e',
        project_vars Scope Funs fenv c Γ FVs ys C Scope' Funs' ->
        Closure_conversion (x |: Scope') Funs' fenv c Γ FVs e e' C' ->
        Closure_conversion Scope Funs fenv c Γ FVs (Eprim x f ys e)
                           (Eprim x f ys (C' |[ e' ]|)) C
  | CC_Ehalt :
      forall Scope Scope' Funs Funs' fenv c Γ FVs x C,
        (* Project the function name and the actual parameter *)
        project_var Scope Funs fenv c Γ FVs x C Scope' Funs' ->
        Closure_conversion Scope Funs fenv c Γ FVs (Ehalt x) (Ehalt x) C
  with Closure_conversion_fundefs :
         fundefs -> (* The current block. Needed to make closures upon entry. *)
         cTag -> (* tag of the current environment constructor *)
         list var -> (* The environment *)
         fundefs -> (* Before cc *)
         fundefs -> (* After cc *)
         Prop :=
       | CC_Fccons :
           forall B c Γ' FVs S f t ys e e' C defs defs',
             (* The environment binding should not shadow the current scope
               (i.e. the names of the mut. rec. functions and the other arguments) *)
             Disjoint _ S ((name_in_fundefs B) :|: (FromList ys) :|: (bound_var e) :|: FromList FVs) ->
             (* new argument *)
             In _ S  Γ' ->
             Closure_conversion_fundefs B c FVs defs defs' ->
             Closure_conversion (FromList ys) (name_in_fundefs B) (extend_fundefs' id B Γ')
                                c Γ' FVs e e' C ->
             Closure_conversion_fundefs B c FVs (Fcons f t ys e defs )
                                        (Fcons f t (Γ' :: ys) (C |[ e' ]|) defs')
       | CC_Fnil :
           forall B c FVs,
             Closure_conversion_fundefs B c FVs Fnil Fnil.

  (** * Computational definition of closure conversion *)

  Inductive VarInfo : Type :=
  (* A free variable, i.e. a variable outside the scope of the current function.
   The argument is position of a free variable in the env record *)
  | FVar : N -> VarInfo
  (* A function defined in the current block of function definitions. The first
   argument is the closure environment  *)
  | MRFun : var -> VarInfo
  (* A variable declared in the scope of the current function *)
  | BoundVar : VarInfo.

  (* Maps variables to [VarInfo] *)
  Definition VarInfoMap := M.t VarInfo.

  Record state_contents :=
    mkSt { var_map : VarInfoMap ;
           next_var : var ; (* next fresh name *)
           nect_cTag : cTag ; (* next unique tag for closures *)
           next_iTag : iTag; cenv : cEnv;
           name_env : M.t BasicAst.name }.

  (** The state is the next available free variable, cTag and iTag and the tag environment *)
  Definition ccstate :=
    state state_contents.

  Definition get_var_entry (x : var) : ccstate (option VarInfo)  :=
    p <- get ;;
    let '(mkSt vm n c i e names) := p in
    match vm ! x with
      | Some info => ret (Some info)
      | None => ret None
    end.

  Definition set_var_entry (x : var) (info : VarInfo) : ccstate unit :=
    p <- get ;;
    let '(mkSt vm n c i e names) := p in
    put (mkSt (M.set x info vm) n c i e names) ;;
    ret tt.

  (** Get a the name entry of a variable *)
  Definition get_name_entry (x : var) : ccstate BasicAst.name :=
    p <- get ;;
    let '(mkSt vm n c i e names) := p in
    match names ! x with
      | Some name => ret name
      | None => ret nAnon
    end.

  (** Set a the name entry of a variable *)
  Definition set_name_entry (x : var) (name : BasicAst.name) : ccstate unit :=
    p <- get ;;
    let '(mkSt vm n c i e names) := p in
    put (mkSt vm n c i e (M.set x name names)) ;;
    ret tt.

  Definition pop_var_map (t : unit) : ccstate VarInfoMap :=
    p <- get ;;
    let '(mkSt vm n c i e names) := p in
    put (mkSt (M.empty VarInfo) n c i e names) ;;
    ret vm.

  Definition peak_var_map (t : unit) : ccstate VarInfoMap :=
    p <- get ;;
    let '(mkSt vm n c i e names) := p in
    ret vm.

  Definition push_var_map (map : VarInfoMap) : ccstate unit :=
    p <- get ;;
    let '(mkSt vm n c i e names) := p in
    put (mkSt map n c i e names) ;;
    ret tt.

  (* (** Add name *) *)
  Definition add_name (fresh : var) (name : string): ccstate unit :=
    set_name_entry fresh (nNamed name).

  (** Add_name as suffix *)
  Definition add_name_suff (fresh old : var) (suff : string) :=
    oldn <- get_name_entry old ;;
    match oldn with
      | nNamed s =>
        set_name_entry fresh (nNamed (append s suff))
      | nAnon =>
        set_name_entry fresh (nNamed (append "anon" suff))
    end.

  (** Commonly used suffixes *)
  Definition clo_env_suffix := "_env".
  Definition clo_suffix := "_clo".
  Definition code_suffix := "_code".
  Definition proj_suffix := "_proj".

  (** Get a fresh name, and create a pretty name *)
  Definition get_name (old_var : var) (suff : string) : ccstate var :=
    p <- get ;;
    let '(mkSt vm n c i e names) := p in
    put (mkSt vm ((n+1)%positive) c i e names) ;;
    add_name_suff n old_var suff ;;
    ret n.

  (** Get a fresh name, and create a pretty name *)
  Definition get_name_no_suff (name : string) : ccstate var :=
    p <- get ;;
    let '(mkSt vm n c i e names) := p in
    put (mkSt vm ((n+1)%positive) c i e names) ;;
    add_name n name ;;
    ret n.

  Definition make_record_cTag (n : N) : ccstate cTag :=
    p <- get ;;
    let '(mkSt vm x c i e names) := p  in
    let inf := (nAnon, nAnon, i, n, 0%N) : cTyInfo in
    let e' := ((M.set c inf e) : cEnv) in
    put (mkSt vm x (c+1)%positive (i+1)%positive e' names) ;;
    ret c.

  (** Looks up a variable in the map and handles it appropriately *)
  Definition get_var (x : var) (c : cTag) (Γ : var): ccstate exp_ctx :=
    info <- get_var_entry x ;;
    match info with
      | Some entry =>
        match entry with
        | FVar pos =>
          set_var_entry x BoundVar ;;
          ret (Eproj_c x c pos Γ Hole_c)
        | MRFun env_ptr  =>
          set_var_entry x BoundVar ;;
          ret (Econstr_c x clo_tag [x; env_ptr] Hole_c)
        | BoundVar => ret Hole_c
        end
      | None => ret Hole_c (* should never reach here *)
    end.

  Fixpoint get_vars (xs : list var) (c : cTag) (Γ : var) : ccstate exp_ctx :=
    match xs with
      | [] => ret Hole_c
      | x :: xs =>
        C1 <- get_var x c Γ ;;
        C2 <- get_vars xs c Γ ;;
        ret (comp_ctx_f C1 C2)
    end.

  (** Add some bound variables in the map *)
  Fixpoint add_params args : ccstate unit :=
    match args with
      | [] => ret tt
      | x :: xs =>
        set_var_entry x BoundVar ;;
        add_params xs
    end.

  (** Add the free variables in the map *)
  Fixpoint add_fvs xs n : ccstate unit :=
    match xs with
      | [] => ret tt
      | x :: xs =>
        set_var_entry x (FVar n) ;;
        add_fvs xs (n + 1)%N
    end.

  Fixpoint add_funs B Γ : ccstate unit :=
    match B with
    | Fcons f typ xs e B' =>
      set_var_entry f (MRFun Γ) ;;
      add_funs B' Γ
    | Fnil => ret tt
    end.

  (** Construct the closure environment  *)
  Definition make_env (fvs : list var) (c_old : cTag) (Γ_new Γ_old : var)
  : ccstate (cTag * exp_ctx) :=
    C <- get_vars fvs c_old Γ_old  ;;
    c_new <- make_record_cTag (N_as_OT.of_nat (List.length fvs)) ;; (* TODO fix *)
    ret (c_new, comp_ctx_f C (Econstr_c Γ_new c_new fvs Hole_c)).

  Fixpoint exp_closure_conv (e : exp)
           (c : cTag) (Γ : var) : ccstate (exp * exp_ctx) :=
    match e with
    | Econstr x tag ys e' =>
      C1 <- get_vars ys c Γ ;;
      set_var_entry x BoundVar ;;
      ef <- exp_closure_conv e' c Γ ;;
      let (e_cc, C) := ef in
      ret (Econstr x tag ys (C |[ e_cc ]|), C1)
    | Ecase x pats =>
      C1 <- get_var x c Γ ;;
      pats' <-
      (fix mapM_cc l :=
         match l with
         | [] => ret []
         | (y, e) :: xs =>
           var_map <- peak_var_map tt ;;
           ef <- exp_closure_conv e c Γ ;;
           push_var_map var_map ;;
           xs' <- mapM_cc xs ;;
           ret ((y, ((snd ef) |[ fst ef ]|)) :: xs')
         end) pats;;
        ret (Ecase x pats', C1)
      | Eproj x tag n y e' =>
        C1 <- get_var y c Γ ;;
        set_var_entry x BoundVar ;;
        ef <- exp_closure_conv e' c Γ ;;
        let (e_cc, C) := ef in
        ret (Eproj x tag n y (C |[ e_cc ]|), C1)
      | Efun defs e =>
        (* precompute free vars so this computation does not mess up the complexity *)
        let fv_set := fundefs_fv defs in
        let fvs := PS.elements fv_set in
        Γ' <- get_name_no_suff "env";;
        t1 <- make_env fvs c Γ' Γ ;;
        let '(c', Cenv) := t1 in
        (* fundefs *)
        var_map <- pop_var_map tt ;;
        add_fvs fvs 0%N ;;
        defs' <- fundefs_closure_conv defs defs c' ;;
        push_var_map var_map ;;
        (* end fundefs *)
        add_funs defs Γ' ;;
        ef <- exp_closure_conv e c Γ ;;
        let (e_cc, C) := ef in
        ret (Efun defs' (C |[ e_cc ]|), Cenv)
      | Eapp f ft xs =>
        C1 <- get_vars (f :: xs) c Γ ;;
        ptr <- get_name f code_suffix ;;
        Γ <- get_name f clo_env_suffix ;;
        ret (Eproj ptr clo_tag 0 f
                   (Eproj Γ clo_tag 1 f
                          (Eapp ptr ft (Γ :: xs))), C1)
    | Eprim x prim ys e' =>
      C1 <- get_vars ys c Γ ;;
      set_var_entry x BoundVar ;;
      ef <- exp_closure_conv e' c Γ ;;
      let (e_cc, C) := ef in
      ret (Eprim x prim ys (C |[ e_cc ]|), C1)
    | Ehalt x =>
      C1 <- get_var x c Γ ;;
      ret (Ehalt x, C1)
    end
  with fundefs_closure_conv B (defs : fundefs) (c : cTag)
       : ccstate fundefs  :=
         match defs with
           | Fcons f tag ys e defs' =>
             var_map <- peak_var_map tt ;;
             (* formal parameter for the environment pointer *)
             Γ <- get_name f clo_env_suffix ;;
             add_funs B Γ ;;
             (* Add arguments to the map *)
             add_params ys ;;
             ef <- exp_closure_conv e c Γ ;;
             let (e_cc, C) := ef in
             push_var_map var_map ;;
             defs'' <- fundefs_closure_conv B defs' c ;;
             ret (Fcons f tag (Γ :: ys) (C |[ e_cc ]|) defs'')
           | Fnil => ret Fnil
         end.

  (* Toplevel closure conversion program *)
  Definition closure_conversion_top
             (e : exp) (c : cTag) (Γ : var) (i : iTag) (cenv : cEnv) (nmap:M.t BasicAst.name) : exp * exp_ctx :=
    let next := ((Pos.max (max_var e 1%positive) Γ) + 1)%positive in
    let state := mkSt (Maps.PTree.empty VarInfo) next c i cenv nmap in
    let '(e, C, s) := runState
                        (exp_closure_conv e 1%positive Γ)
                        state in

    (e, C).

End CC.


(* DEC1 language development.
   Paolo Torrini,
   Universite' Lille-1 - CRIStAL-CNRS
*)
(* inversion lemmas for the step rules *)
Require Export Basics.
Require Export EnvLibA.
Require Export RelLibA.

Require Export Coq.Program.Equality.
Require Import Coq.Init.Specif.
Require Import Coq.Arith.PeanoNat.
Require Import Omega.
Require Import Coq.Lists.List.

Require Import IdModTypeA.
Require Import StaticSemA.
Require Import TRInductA.
Require Import WeakenA.
Require Import TSoundnessA.
Require Import IdModTypeA.
Require Import DetermA.
Require Import WeakenA.
Require Import AbbrevA.

Import ListNotations.

Module Invert (IdT: IdModType) <: IdModType.

Definition Id := IdT.Id.
Definition IdEqDec := IdT.IdEqDec.
Definition IdEq := IdT.IdEq.
Definition W := IdT.W.
Definition Loc_PI := IdT.Loc_PI.
Definition BInit := IdT.BInit.
Definition WP := IdT.WP.

Module AbbrevI := Abbrev IdT.
Export AbbrevI.

(** inverse big-step lemmas (using modules up to Weaken) *)

Lemma BindN_BStep1 (fenv: funEnv) (env: valEnv)
      (e1 e2: Exp) (v: Value) (s s': W) :
  (forall (e:Exp) (s: W), sigT (fun v: Value =>
                 sigT (fun s': W =>
      EClosure fenv env (Conf Exp s e) (Conf Exp s' (Val v))))) ->
  (forall (e:Exp) (s s1 s2: W) (v1 v2: Value),
      EClosure fenv env (Conf Exp s e) (Conf Exp s1 (Val v1)) ->
      EClosure fenv env (Conf Exp s e) (Conf Exp s2 (Val v2)) ->
        (s1 = s2) /\ (v1 = v2)) ->
  EClosure fenv env (Conf Exp s (BindN e1 e2)) (Conf Exp s' (Val v)) ->
  (sigT2 (fun s1 : W =>
            (sigT (fun v1: Value =>
                     EClosure fenv env (Conf Exp s e1) (Conf Exp s1 (Val v1)))))
         (fun s1 : W =>
            EClosure fenv env (Conf Exp s1 e2) (Conf Exp s' (Val v)))).
  intros X K.
  intros.
  generalize X.
  intro X1.
  specialize (X e1 s).
  destruct X as [v1 X].
  destruct X as [s1 X].
  specialize (X1 e2 s1).
  destruct X1 as [v2 X1].
  destruct X1 as [s2 X1].

  generalize X.
  intro K1.
  eapply BindN_extended_congruence in X.
  instantiate (1:=e2) in X.

  assert (EStep fenv env (Conf Exp s1 (BindN (Val v1) e2)) (Conf Exp s1 e2)).
  constructor.
  eapply StepIsEClos in X2.

  assert (EClosure fenv env (Conf Exp s (BindN e1 e2)) (Conf Exp s1 e2)).
  eapply EClosConcat.
  exact X.
  assumption.

  assert (EClosure fenv env (Conf Exp s (BindN e1 e2)) (Conf Exp s2 (Val v2))).
  eapply EClosConcat.
  exact X3.
  assumption.

  assert (s' = s2 /\ v = v2).
  eapply K.
  eauto.
  assumption.
  destruct H.
  subst.

  econstructor.
  econstructor.
  eauto.
  auto.
Defined.

Lemma BindN_BStep2 (fenv: funEnv) (env: valEnv)
      (e1 e2: Exp) (v: Value) (s s': W) :
  (forall (e:Exp) (s: W), sigT (fun v: Value =>
                 sigT (fun s': W =>
      EClosure fenv env (Conf Exp s e) (Conf Exp s' (Val v))))) ->
  (forall (e:Exp) (s s1 s2: W) (v1 v2: Value),
      EClosure fenv env (Conf Exp s e) (Conf Exp s1 (Val v1)) ->
      EClosure fenv env (Conf Exp s e) (Conf Exp s2 (Val v2)) ->
        (s1 = s2) /\ (v1 = v2)) ->
  EClosure fenv env (Conf Exp s (BindN e1 e2)) (Conf Exp s' (Val v)) ->
  forall (s1 : W) (v1: Value),
    EClosure fenv env (Conf Exp s e1) (Conf Exp s1 (Val v1)) ->
    EClosure fenv env (Conf Exp s1 e2) (Conf Exp s' (Val v)).
  intros.
  generalize X1.
  intro X2.
  eapply BindN_extended_congruence in X1.
  instantiate (1:= e2) in X1.

  assert (EStep fenv env (Conf Exp s1 (BindN (Val v1) e2)) (Conf Exp s1 e2)).
  constructor.
  eapply StepIsEClos in X3.
  assert (EClosure fenv env (Conf Exp s (BindN e1 e2)) (Conf Exp s1 e2)).
  eapply EClosConcat.
  exact X1.
  auto.
  specialize (X e2 s1).
  destruct X as [v2 X].
  destruct X as [s2 X].
  assert (EClosure fenv env (Conf Exp s (BindN e1 e2)) (Conf Exp s2 (Val v2))).
  eapply EClosConcat.
  exact X4.
  auto.
  assert (s' = s2 /\ v = v2).
  eapply H.
  exact X0.
  auto.
  destruct H0.
  subst.
  auto.
Defined.

Lemma BindS_BStep1 (fenv: funEnv) (env: valEnv)
      (e1 e2: Exp) (x: Id) (v: Value) (s s': W) :
  (forall (fenv: funEnv) (env: valEnv) (e:Exp) (s: W), sigT (fun v: Value =>
                 sigT (fun s': W =>
      EClosure fenv env (Conf Exp s e) (Conf Exp s' (Val v))))) ->
  (forall (e:Exp) (s s1 s2: W) (v1 v2: Value),
      EClosure fenv env (Conf Exp s e) (Conf Exp s1 (Val v1)) ->
      EClosure fenv env (Conf Exp s e) (Conf Exp s2 (Val v2)) ->
        (s1 = s2) /\ (v1 = v2)) ->
  EClosure fenv env (Conf Exp s (BindS x e1 e2)) (Conf Exp s' (Val v)) ->
  sigT (fun s1 : W =>
     (sigT2 (fun v1: Value =>
        EClosure fenv env (Conf Exp s e1) (Conf Exp s1 (Val v1)))
              (fun v1 : Value =>
        EClosure fenv ((x,v1)::env) (Conf Exp s1 e2) (Conf Exp s' (Val v))))).
  intros X K.
  intros.
  generalize X.
  intro X1.
  specialize (X fenv env e1 s).
  destruct X as [v1 X].
  destruct X as [s1 X].
  generalize X.
  intro K1.
  eapply BindS_extended_congruence in X.
  instantiate (1:=e2) in X.
  instantiate (1:=x) in X.

  assert (EStep fenv env (Conf Exp s1 (BindS x (Val v1) e2))
                         (Conf Exp s1 (BindMS emptyE [(x,v1)] e2))).
  constructor.
  eapply StepIsEClos in X2.

  assert (EClosure fenv env (Conf Exp s (BindS x e1 e2))
                            (Conf Exp s1 (BindMS emptyE [(x,v1)] e2))).
  eapply EClosConcat.
  exact X.
  assumption.

  specialize (X1 fenv ((x,v1)::env) e2 s1).
  destruct X1 as [v2 X1].
  destruct X1 as [s2 X1].

  assert (EClosure fenv env (Conf Exp s (BindS x e1 e2))
                            (Conf Exp s2 (Val v2))).
  eapply EClosConcat.
  exact X3.

  assert (EClosure fenv env (Conf Exp s1 (BindMS emptyE [(x, v1)] e2))
                            (Conf Exp s2 (BindMS emptyE [(x, v1)] (Val v2)))).
  eapply BindMS_extended_congruence.
  reflexivity.
  reflexivity.
  assumption.

  eapply EClosConcat.
  exact X4.
  eapply StepIsEClos.
  constructor.

  assert (s' = s2 /\ v = v2).
  eapply K.
  eauto.
  assumption.
  destruct H.
  subst.

  econstructor.
  econstructor.
  eauto.
  auto.
Defined.

Lemma Apply_BStep1 (fenv: funEnv) (env: valEnv)
      (f: Fun) (es: list Exp) (v: Value) (s s': W) :
  (forall (fenv: funEnv) (env: valEnv) (e:Exp) (s: W), sigT (fun v: Value =>
                 sigT (fun s': W =>
      EClosure fenv env (Conf Exp s e) (Conf Exp s' (Val v))))) ->
  (forall (fenv: funEnv) (env: valEnv) (es:list Exp) (s: W),
      sigT (fun vs: list Value =>
                 sigT (fun s': W =>
      PrmsClosure fenv env (Conf Prms s (PS es))
                           (Conf Prms s' (PS (map Val vs)))))) ->
   (forall (e:Exp) (s s1 s2: W) (v1 v2: Value),
      EClosure fenv env (Conf Exp s e) (Conf Exp s1 (Val v1)) ->
      EClosure fenv env (Conf Exp s e) (Conf Exp s2 (Val v2)) ->
        (s1 = s2) /\ (v1 = v2)) ->

   match f as f with
    | FC fenv' tenv' e0 e1 x n =>
  length tenv' = length es ->
  EClosure fenv env (Conf Exp s (Apply (QF f) (PS es)))
                                (Conf Exp s' (Val v)) ->
  sigT (fun s1 : W =>
     (sigT2 (fun vs: list Value =>
               PrmsClosure fenv env (Conf Prms s (PS es))
                                    (Conf Prms s1 (PS (map Val vs))))
            (fun vs : list Value =>
    match n with
    | 0 =>
      EClosure fenv' (mkVEnv tenv' vs) (Conf Exp s1 e0)
                                       (Conf Exp s' (Val v))
    | S n' =>
      EClosure ((x, FC fenv' tenv' e0 e1 x n') :: fenv')
         (mkVEnv tenv' vs) (Conf Exp s1 e1) (Conf Exp s' (Val v))
    end)))
   end.

Proof.
  intros P1 P2 P3.
  destruct f.
  intros.

  generalize P2.
  intro P0.
  specialize (P0 fenv env es s).
  destruct P0 as [vs P0].
  destruct P0 as [s1 P0].
  generalize P0.
  intro X0.
  eapply Apply1_extended_congruence with (f:=(FC fenv0 tenv e0 e1 x n)) in X0.

  econstructor.
  instantiate (1:=s1).

  generalize P0.
  intro P6.
  eapply PrmsClos_aux0 in P6.
  rewrite map_length with (f:=Val) in P6.
  rewrite P6 in H.
  clear P6.

  econstructor.
  instantiate (1:=vs).
  exact P0.

  destruct n.
(**)
  generalize P1.
  intro P5.
  specialize (P5 fenv0 (mkVEnv tenv vs) e0 s1).
  destruct P5 as [v2 P5].
  destruct P5 as [s2 P5].

  assert (EClosure fenv env (Conf Exp s1
            (Apply (QF (FC fenv0 tenv e0 e1 x 0)) (PS (map Val vs))))
                   (Conf Exp s1 (BindMS fenv0 (mkVEnv tenv vs) e0))).             eapply StepIsEClos.
  econstructor.
  econstructor.
  reflexivity.
  exact H.
  reflexivity.

  assert (EClosure fenv env (Conf Exp s1 (BindMS fenv0 (mkVEnv tenv vs) e0))
                       (Conf Exp s2 (BindMS fenv0 (mkVEnv tenv vs) (Val v2)))).
  eapply BindMS_extended_congruence.
  reflexivity.
  reflexivity.
  eapply weaken.
  exact P5.

  assert (EClosure fenv env
                   (Conf Exp s2 (BindMS fenv0 (mkVEnv tenv vs) (Val v2)))
                   (Conf Exp s2 (Val v2))).
  eapply StepIsEClos.
  econstructor.

  assert (EClosure fenv env
        (Conf Exp s (Apply (QF (FC fenv0 tenv e0 e1 x 0)) (PS es)))
        (Conf Exp s2 (Val v2))).
  eapply EClosConcat.
  exact X0.
  eapply EClosConcat.
  exact X1.
  eapply EClosConcat.
  exact X2.
  exact X3.

  assert (s' = s2 /\ v = v2).
  eapply P3.
  exact X.
  exact X4.

  destruct H0.
  subst.
  exact P5.
(**)

  generalize P1.
  intro P5.
  set ((x, FC fenv0 tenv e0 e1 x n) :: fenv0) as fenv'.

  specialize (P5 fenv' (mkVEnv tenv vs) e1 s1).
  destruct P5 as [v2 P5].
  destruct P5 as [s2 P5].

  assert (EClosure fenv env (Conf Exp s1
            (Apply (QF (FC fenv0 tenv e0 e1 x (S n))) (PS (map Val vs))))
                   (Conf Exp s1
                         (BindMS fenv' (mkVEnv tenv vs) e1))).
  eapply StepIsEClos.
  econstructor.
  econstructor.
  reflexivity.
  exact H.
  reflexivity.

  assert (EClosure fenv env (Conf Exp s1 (BindMS fenv' (mkVEnv tenv vs) e1))
                       (Conf Exp s2 (BindMS fenv' (mkVEnv tenv vs) (Val v2)))).
  eapply BindMS_extended_congruence.
  reflexivity.
  reflexivity.
  eapply weaken.
  exact P5.

  assert (EClosure fenv env
                   (Conf Exp s2 (BindMS fenv' (mkVEnv tenv vs) (Val v2)))
                   (Conf Exp s2 (Val v2))).
  eapply StepIsEClos.
  econstructor.

  assert (EClosure fenv env
        (Conf Exp s (Apply (QF (FC fenv0 tenv e0 e1 x (S n))) (PS es)))
        (Conf Exp s2 (Val v2))).
  eapply EClosConcat.
  exact X0.
  eapply EClosConcat.
  exact X1.
  eapply EClosConcat.
  exact X2.
  exact X3.

  assert (s' = s2 /\ v = v2).
  eapply P3.
  exact X.
  exact X4.

  destruct H0.
  subst.
  exact P5.
Defined.

(*********************************************************************)

(** further inverse big-step lemmas *)

Lemma BindN_BStepT1 (ftenv: funTC) (tenv: valTC)
      (fenv: funEnv) (env: valEnv)
      (e1 e2: Exp) (v: Value) (s s': W)
      (k1: FEnvTyping fenv ftenv)
      (k2: EnvTyping env tenv) (t: VTyp)
      (k3: ExpTyping ftenv tenv fenv (BindN e1 e2) t) :
  EClosure fenv env (Conf Exp s (BindN e1 e2)) (Conf Exp s' (Val v)) ->
  (sigT2 (fun s1 : W =>
            (sigT (fun v1: Value =>
                     EClosure fenv env (Conf Exp s e1) (Conf Exp s1 (Val v1)))))
         (fun s1 : W =>
            EClosure fenv env (Conf Exp s1 e2) (Conf Exp s' (Val v)))).
  intros.
  inversion k3; subst.
  rename X0 into Y1.
  rename X1 into Y2.
  rename t into t2.

  assert (ExpSoundness ftenv tenv fenv e1 t1 Y1) as X1.
  eapply (ExpEval ftenv tenv fenv e1 t1 Y1).
  unfold ExpSoundness in X1.
  unfold SoundExp in X1.
  specialize (X1 k1 env k2 s).
  destruct X1 as [v1 k4 X1].
  destruct X1 as [s1 X1].

  generalize X1.
  intro.

  assert (ExpSoundness ftenv tenv fenv e2 t2 Y2) as X2.
  eapply (ExpEval ftenv tenv fenv e2 t2 Y2).
  unfold ExpSoundness in X2.
  unfold SoundExp in X2.
  specialize (X2 k1 env k2 s1).
  destruct X2 as [v2 k5 X2].
  destruct X2 as [s2 X2].

  eapply BindN_extended_congruence in X1.
  instantiate (1:=e2) in X1.

  assert (EStep fenv env (Conf Exp s1 (BindN (Val v1) e2)) (Conf Exp s1 e2)).
  constructor.
  eapply StepIsEClos in X3.

  assert (EClosure fenv env (Conf Exp s (BindN e1 e2)) (Conf Exp s1 e2)).
  eapply EClosConcat.
  exact X1.
  assumption.

  assert (EClosure fenv env (Conf Exp s (BindN e1 e2)) (Conf Exp s2 (Val v2))).
  eapply EClosConcat.
  exact X4.
  assumption.

  assert (s' = s2 /\ v = v2).
  eapply ExpConfluence.
  exact k3.
  auto.
  eauto.
  eauto.
  auto.

  destruct H.
  subst.

  econstructor.
  econstructor.
  eauto.
  auto.
Defined.

Lemma BindS_BStepT1 (ftenv: funTC) (tenv: valTC)
      (fenv: funEnv) (env: valEnv)
      (e1 e2: Exp) (x: Id) (v: Value) (s s': W)
      (k1: FEnvTyping fenv ftenv)
      (k2: EnvTyping env tenv) (t: VTyp)
      (k3: ExpTyping ftenv tenv fenv (BindS x e1 e2) t) :
  EClosure fenv env (Conf Exp s (BindS x e1 e2)) (Conf Exp s' (Val v)) ->
  sigT (fun s1 : W =>
     (sigT2 (fun v1: Value =>
        EClosure fenv env (Conf Exp s e1) (Conf Exp s1 (Val v1)))
              (fun v1 : Value =>
        EClosure fenv ((x,v1)::env) (Conf Exp s1 e2) (Conf Exp s' (Val v))))).
  intros.
  inversion k3; subst.
  rename X0 into Y1.
  rename X1 into Y2.
  rename t into t2.

  assert (ExpSoundness ftenv tenv fenv e1 t1 Y1) as X1.
  eapply (ExpEval ftenv tenv fenv e1 t1 Y1).
  unfold ExpSoundness in X1.
  unfold SoundExp in X1.
  specialize (X1 k1 env k2 s).
  destruct X1 as [v1 k4 X1].
  destruct X1 as [s1 X1].

  generalize X1.
  intro.

  eapply BindS_extended_congruence in X1.
  instantiate (1:=e2) in X1.
  instantiate (1:=x) in X1.

  assert (EStep fenv env (Conf Exp s1 (BindS x (Val v1) e2))
                         (Conf Exp s1 (BindMS emptyE [(x,v1)] e2))).
  constructor.
  eapply StepIsEClos in X2.

  assert (EClosure fenv env (Conf Exp s (BindS x e1 e2))
                            (Conf Exp s1 (BindMS emptyE [(x,v1)] e2))).
  eapply EClosConcat.
  exact X1.
  assumption.

  assert (ExpSoundness ftenv tenv' fenv e2 t2 Y2) as X4.
  eapply (ExpEval ftenv tenv' fenv e2 t2 Y2).
  unfold ExpSoundness in X4.
  unfold SoundExp in X4.

  assert (MatchEnvsT ValueTyping ((x, v1) :: env) tenv').
  econstructor.
  auto.
  auto.
  specialize (X4 k1 ((x,v1)::env) X5 s1).
  destruct X4 as [v2 k5 X4].
  destruct X4 as [s2 X4].

  assert (EClosure fenv env (Conf Exp s (BindS x e1 e2))
                            (Conf Exp s2 (Val v2))).
  eapply EClosConcat.
  exact X3.

  assert (EClosure fenv env (Conf Exp s1 (BindMS emptyE [(x, v1)] e2))
                            (Conf Exp s2 (BindMS emptyE [(x, v1)] (Val v2)))).
  eapply BindMS_extended_congruence.
  reflexivity.
  reflexivity.
  assumption.

  eapply EClosConcat.
  exact X6.
  eapply StepIsEClos.
  constructor.

  assert (s' = s2 /\ v = v2).
  eapply ExpConfluence.
  exact k3.
  auto.
  eauto.
  eauto.
  auto.

  destruct H.
  subst.

  econstructor.
  econstructor.
  eauto.
  auto.
Defined.

Lemma Apply_BStepT1 (ftenv: funTC) (tenv: valTC)
      (fenv: funEnv) (env: valEnv)
      (f: Fun) (es: list Exp) (v: Value) (s s': W)
      (k1: FEnvTyping fenv ftenv)
      (k2: EnvTyping env tenv) (t: VTyp)
      (k3: ExpTyping ftenv tenv fenv (Apply (QF f) (PS es)) t) :
   match f as f with
    | FC fenv' tenv' e0 e1 x n =>
  length tenv' = length es ->
  EClosure fenv env (Conf Exp s (Apply (QF f) (PS es)))
                                (Conf Exp s' (Val v)) ->
  sigT (fun s1 : W =>
     (sigT2 (fun vs: list Value =>
               PrmsClosure fenv env (Conf Prms s (PS es))
                                    (Conf Prms s1 (PS (map Val vs))))
            (fun vs : list Value =>
    match n with
    | 0 =>
      EClosure fenv' (mkVEnv tenv' vs) (Conf Exp s1 e0)
                                       (Conf Exp s' (Val v))
    | S n' =>
      EClosure ((x, FC fenv' tenv' e0 e1 x n') :: fenv')
         (mkVEnv tenv' vs) (Conf Exp s1 e1) (Conf Exp s' (Val v))
    end)))
   end.

Proof.
  destruct f.
  intros.
  inversion k3; subst.
  rename X1 into Y2.
  rename X2 into Y1.

  assert (PrmsSoundness ftenv tenv fenv (PS es) (PT (map snd fps)) Y1) as X1.
  eapply (PrmsEval ftenv tenv fenv (PS es) (PT (map snd fps)) Y1).
  unfold PrmsSoundness in X1.
  unfold SoundPrms in X1.
  specialize (X1 k1 env k2 s).
  destruct X1 as [es1 X1].
  destruct X1 as [vs k4 X1].
  destruct X1 as [k5 X1].
  destruct X1 as [s1 X1].

  generalize X1.
  intro.

  eapply Apply1_extended_congruence with (f:=(FC fenv0 tenv0 e0 e1 x n)) in X1.

  econstructor.
  instantiate (1:=s1).

  generalize X2.
  intro P6.
  eapply PrmsClos_aux0 in P6.
  inversion k4; subst.

  rewrite map_length with (f:=Val) in P6.
  rewrite P6 in H.
  clear P6.

  econstructor.
  instantiate (1:=vs).
  auto.

  destruct n.
  (**)
  inversion Y2; subst.
  inversion X3; subst.

  assert (ExpSoundness ftenv0 fps fenv0 e0 t X5) as X6.
  eapply (ExpEval ftenv0 fps fenv0 e0 t X5).
  unfold ExpSoundness in X6.
  unfold SoundExp in X6.

  assert (MatchEnvsT ValueTyping (mkVEnv fps vs) fps).
  eapply prmsTypingAux_T.
  auto.
  eapply matchListsAux02_T.
  eauto.
  eauto.

  specialize (X6 X4 (mkVEnv fps vs) X7 s1).
  destruct X6 as [v2 k7 P5].
  destruct P5 as [s2 P5].

  assert (EClosure fenv env (Conf Exp s1
            (Apply (QF (FC fenv0 fps e0 e1 x 0)) (PS (map Val vs))))
                   (Conf Exp s1 (BindMS fenv0 (mkVEnv fps vs) e0))) as A1.        eapply StepIsEClos.
  econstructor.
  econstructor.
  reflexivity.
  exact H.
  reflexivity.

  assert (EClosure fenv env (Conf Exp s1 (BindMS fenv0 (mkVEnv fps vs) e0))
                 (Conf Exp s2 (BindMS fenv0 (mkVEnv fps vs) (Val v2)))) as A2.
  eapply BindMS_extended_congruence.
  reflexivity.
  reflexivity.
  eapply weaken.
  exact P5.

  assert (EClosure fenv env
                   (Conf Exp s2 (BindMS fenv0 (mkVEnv fps vs) (Val v2)))
                   (Conf Exp s2 (Val v2))) as A3.
  eapply StepIsEClos.
  econstructor.

  assert (EClosure fenv env
        (Conf Exp s (Apply (QF (FC fenv0 fps e0 e1 x 0)) (PS es)))
        (Conf Exp s2 (Val v2))) as A4.
  eapply EClosConcat.
  exact X1.
  eapply EClosConcat.
  exact A1.
  eapply EClosConcat.
  exact A2.
  exact A3.

  assert (s' = s2 /\ v = v2).
  eapply ExpConfluence.
  exact k3.
  auto.
  eauto.
  eauto.
  auto.

  destruct H0.
  subst.
  exact P5.
(**)

  inversion Y2; subst.
  inversion X3; subst.

  assert (ExpSoundness ftenv' fps fenv' e1 t X5) as X06.
  eapply (ExpEval ftenv' fps fenv' e1 t X5).
  unfold ExpSoundness in X06.
  unfold SoundExp in X06.

  assert (MatchEnvsT ValueTyping (mkVEnv fps vs) fps).
  eapply prmsTypingAux_T.
  auto.
  eapply matchListsAux02_T.
  eauto.
  eauto.

  assert (MatchEnvsT FunTyping fenv' ftenv').
  econstructor.
  auto.
  auto.

  specialize (X06 X8 (mkVEnv fps vs) X7 s1).
  destruct X06 as [v2 k7 P5].
  destruct P5 as [s2 P5].

  assert (EClosure fenv env (Conf Exp s1
            (Apply (QF (FC fenv0 fps e0 e1 x (S n))) (PS (map Val vs))))
                   (Conf Exp s1 (BindMS fenv' (mkVEnv fps vs) e1))) as A1.        eapply StepIsEClos.
  econstructor.
  econstructor.
  reflexivity.
  exact H.
  reflexivity.

  assert (EClosure fenv env (Conf Exp s1 (BindMS fenv' (mkVEnv fps vs) e1))
                 (Conf Exp s2 (BindMS fenv' (mkVEnv fps vs) (Val v2)))) as A2.
  eapply BindMS_extended_congruence.
  reflexivity.
  reflexivity.
  eapply weaken.
  exact P5.

  assert (EClosure fenv env
                   (Conf Exp s2 (BindMS fenv' (mkVEnv fps vs) (Val v2)))
                   (Conf Exp s2 (Val v2))) as A3.
  eapply StepIsEClos.
  econstructor.

  assert (EClosure fenv env
        (Conf Exp s (Apply (QF (FC fenv0 fps e0 e1 x (S n))) (PS es)))
        (Conf Exp s2 (Val v2))) as A4.
  eapply EClosConcat.
  exact X1.
  eapply EClosConcat.
  exact A1.
  eapply EClosConcat.
  exact A2.
  exact A3.

  assert (s' = s2 /\ v = v2).
  eapply ExpConfluence.
  exact k3.
  auto.
  eauto.
  eauto.
  auto.

  destruct H0.
  subst.
  exact P5.
Defined.

Lemma Prms_BStepT1 (ftenv: funTC) (tenv: valTC)
      (fenv: funEnv) (env: valEnv)
      (e: Exp) (es: list Exp) (v: Value) (vs: list Value) (s s': W)
      (k1: FEnvTyping fenv ftenv)
      (k2: EnvTyping env tenv) (pt: PTyp)
      (k3: PrmsTyping ftenv tenv fenv (PS (e::es)) pt) :
  PrmsClosure fenv env (Conf Prms s (PS (e::es)))
                       (Conf Prms s' (PS (map Val (v::vs)))) ->
  (sigT2 (fun s1 : W =>
            (sigT (fun v1: Value =>
                     EClosure fenv env (Conf Exp s e) (Conf Exp s1 (Val v1)))))
         (fun s1 : W =>
            PrmsClosure fenv env (Conf Prms s1 (PS es))
                                 (Conf Prms s' (PS (map Val vs))))).
  intros.
  inversion k3; subst.
  inversion X0; subst.
  rename X1 into Y1.
  rename X2 into Y3.
  rename y into t.
  rename l' into ts.

  assert (ExpSoundness ftenv tenv fenv e t Y1) as X1.
  eapply (ExpEval ftenv tenv fenv e t Y1).
  unfold ExpSoundness in X1.
  unfold SoundExp in X1.
  specialize (X1 k1 env k2 s).
  destruct X1 as [v1 k4 X1].
  destruct X1 as [s1 X1].

  generalize X1.
  intro Y4.

  assert (PrmsTyping ftenv tenv fenv (PS es) (PT ts)) as Y2.
  constructor.
  auto.

  assert (PrmsSoundness ftenv tenv fenv (PS es) (PT ts) Y2) as X2.
  eapply (PrmsEval ftenv tenv fenv (PS es) (PT ts) Y2).
  unfold PrmsSoundness in X2.
  unfold SoundPrms in X2.
  specialize (X2 k1 env k2 s1).
  destruct X2 as [es1 X2].
  destruct X2 as [vs1 Y5 X2].
  destruct X2 as [Y6 X2].
  destruct X2 as [s2 X2].

  inversion Y5; subst.

(**)
  assert (PrmsClosure fenv env (Conf Prms s (PS (e :: es)))
        (Conf Prms s2 (PS (map Val (v1 :: vs1))))).
  eapply Pars_extended_congruence4.
  eauto.
  exact X2.

  constructor 1 with (x:=s1).
  constructor 1 with (x:=v1).
  exact X1.

  assert (s' = s2 /\ vs = vs1).
  eapply PrmsConfluence in X.
  specialize (X X3).
  destruct X.
  split.
  exact H.
  inversion H0; subst.
  auto.
  eauto.
  auto.
  auto.
  destruct H.
  rewrite H.
  rewrite H0.
  auto.
Defined.

Lemma Prms_BStepT2 (ftenv: funTC) (tenv: valTC)
      (fenv: funEnv) (env: valEnv)
      (e: Exp) (es: list Exp) (v: Value) (vs: list Value) (s s': W)
      (k1: FEnvTyping fenv ftenv)
      (k2: EnvTyping env tenv) (pt: PTyp)
      (k3: PrmsTyping ftenv tenv fenv (PS (e::es)) pt) :
  PrmsClosure fenv env (Conf Prms s (PS (e::es)))
                       (Conf Prms s' (PS (map Val (v::vs)))) ->
  (sigT2 (fun s1 : W =>
            (EClosure fenv env (Conf Exp s e) (Conf Exp s1 (Val v))))
         (fun s1 : W =>
            PrmsClosure fenv env (Conf Prms s1 (PS es))
                                 (Conf Prms s' (PS (map Val vs))))).
  intros.
  inversion k3; subst.
  inversion X0; subst.
  rename X1 into Y1.
  rename X2 into Y3.
  rename y into t.
  rename l' into ts.

  assert (ExpSoundness ftenv tenv fenv e t Y1) as X1.
  eapply (ExpEval ftenv tenv fenv e t Y1).
  unfold ExpSoundness in X1.
  unfold SoundExp in X1.
  specialize (X1 k1 env k2 s).
  destruct X1 as [v1 k4 X1].
  destruct X1 as [s1 X1].

(*
  generalize X1.
  intro Y4.
*)
  assert (PrmsTyping ftenv tenv fenv (PS es) (PT ts)) as Y2.
  constructor.
  auto.

  assert (PrmsSoundness ftenv tenv fenv (PS es) (PT ts) Y2) as X2.
  eapply (PrmsEval ftenv tenv fenv (PS es) (PT ts) Y2).
  unfold PrmsSoundness in X2.
  unfold SoundPrms in X2.
  specialize (X2 k1 env k2 s1).

  destruct X2 as [es1 X2].
  destruct X2 as [vs1 Y5 X2].
  destruct X2 as [Y6 X2].
  destruct X2 as [s2 X2].
  inversion Y5; subst.

  assert (PrmsClosure fenv env (Conf Prms s (PS (e :: es)))
        (Conf Prms s2 (PS (map Val (v1 :: vs1))))).
  eapply Pars_extended_congruence4.
  eauto.
  exact X2.

  (**)
  assert (s' = s2 /\ (v::vs) = (v1::vs1)).
  eapply PrmsConfluence in X.
  specialize (X X3).
  exact X.

  eauto.
  auto.
  auto.
  destruct H.
  injection H0.
  intros.

  constructor 1 with (x:=s1).
  rewrite H2.
  auto.
  rewrite H.
  rewrite H1.
  auto.
Defined.

Lemma IfThenElse_BStepT1 (ftenv: funTC) (tenv: valTC)
      (fenv: funEnv) (env: valEnv)
      (e1 e2 e3: Exp) (v: Value) (s s': W)
      (k1: FEnvTyping fenv ftenv)
      (k2: EnvTyping env tenv) (t: VTyp)
      (k3: ExpTyping ftenv tenv fenv (IfThenElse e1 e2 e3) t) :
  EClosure fenv env (Conf Exp s (IfThenElse e1 e2 e3)) (Conf Exp s' (Val v)) ->
  sum (sigT2 (fun s1 : W =>
        EClosure fenv env (Conf Exp s e1) (Conf Exp s1 (Val (cst bool true))))           (fun s1 : W =>
             (EClosure fenv env (Conf Exp s1 e2) (Conf Exp s' (Val v)))))
      (sigT2 (fun s1 : W =>
      EClosure fenv env (Conf Exp s e1) (Conf Exp s1 (Val (cst bool false))))           (fun s1 : W =>
             (EClosure fenv env (Conf Exp s1 e3) (Conf Exp s' (Val v))))).
Proof.
  intros.
  inversion k3; subst.

  assert (ExpSoundness ftenv tenv fenv e1 Bool X0) as Y1.
  eapply (ExpEval ftenv tenv fenv e1 Bool X0).
  unfold ExpSoundness in Y1.
  unfold SoundExp in Y1.
  specialize (Y1 k1 env k2 s).

  assert (ExpSoundness ftenv tenv fenv e2 t X1) as Y2.
  eapply (ExpEval ftenv tenv fenv e2 t X1).
  unfold ExpSoundness in Y2.
  unfold SoundExp in Y2.
  specialize (Y2 k1 env k2).

  assert (ExpSoundness ftenv tenv fenv e3 t X2) as Y3.
  eapply (ExpEval ftenv tenv fenv e3 t X2).
  unfold ExpSoundness in Y3.
  unfold SoundExp in Y3.
  specialize (Y3 k1 env k2).

  destruct Y1 as [v1 H1 Y1].
  destruct Y1 as [s1 Y1].
  specialize (Y2 s1).
  specialize (Y3 s1).
  destruct v1.
  destruct v0.
  inversion H1; subst.
  simpl in *.
  subst T.
  inversion H; subst.
  clear H2.

  destruct v0.

(**)
  destruct Y2 as [v2 H2 Y2].
  destruct Y2 as [s2 Y2].

  assert (EClosure fenv env (Conf Exp s (IfThenElse e1 e2 e3))
                   (Conf Exp s2 (Val v2))).
  eapply EClosConcat.
  eapply IfThenElse_extended_congruence.
  exact Y1.
  econstructor.
  econstructor.
  exact Y2.

  assert (s' = s2 /\ v = v2).
  eapply (ExpConfluence ftenv tenv fenv (IfThenElse e1 e2 e3) t k3).
  auto.
  eauto.
  exact X.
  auto.
  destruct H.

  constructor.
  econstructor 1 with (x:=s1).
  auto.
  rewrite H.
  rewrite H3.
  exact Y2.

(**)
  clear Y2.
  rename Y3 into Y2.
  destruct Y2 as [v2 H2 Y2].
  destruct Y2 as [s2 Y2].

  assert (EClosure fenv env (Conf Exp s (IfThenElse e1 e2 e3))
                   (Conf Exp s2 (Val v2))).
  eapply EClosConcat.
  eapply IfThenElse_extended_congruence.
  exact Y1.
  econstructor.
  econstructor.
  exact Y2.

  assert (s' = s2 /\ v = v2).
  eapply (ExpConfluence ftenv tenv fenv (IfThenElse e1 e2 e3) t k3).
  auto.
  eauto.
  exact X.
  auto.
  destruct H.

  constructor 2.
  econstructor 1 with (x:=s1).
  auto.
  rewrite H.
  rewrite H3.
  exact Y2.
Qed.

Lemma Apply_BStepT2
      (ftenv: funTC) (tenv: valTC)
      (fenv: funEnv) (env: valEnv)
      (f: Fun) (es: list Exp) (v: Value) (s s': W)
      (k1: FEnvTyping fenv ftenv)
      (k2: EnvTyping env tenv) (t: VTyp)
      (k3: ExpTyping ftenv tenv fenv (Apply (QF f) (PS es)) t) :
  EClosure fenv env (Conf Exp s (Apply (QF f) (PS es)))
                                (Conf Exp s' (Val v)) ->
  sigT (fun s1 : W =>
          (sigT2 (fun vs: list Value =>
               PrmsClosure fenv env (Conf Prms s (PS es))
                                    (Conf Prms s1 (PS (map Val vs))))
            (fun vs : list Value =>
               EClosure fenv env (Conf Exp s1 (Apply (QF f)
                                                  (PS (map Val vs))))
                                 (Conf Exp s' (Val v))))).
Proof.
  intros.
  inversion k3; subst.
  rename X1 into Y2.
  rename X2 into Y1.

  assert (PrmsSoundness ftenv tenv fenv (PS es) (PT (map snd fps)) Y1) as X1.
  eapply (PrmsEval ftenv tenv fenv (PS es) (PT (map snd fps)) Y1).
  unfold PrmsSoundness in X1.
  unfold SoundPrms in X1.
  specialize (X1 k1 env k2 s).
  destruct X1 as [es1 X1].
  destruct X1 as [vs k4 X1].
  destruct X1 as [k5 X1].
  destruct X1 as [s1 X1].

  generalize X1.
  intro.

  eapply Apply1_extended_congruence with (f:=f) in X1.

  econstructor 1 with (x:=s1).

  inversion k4; subst.

  econstructor 1 with (x:=vs).
  auto.

  assert (ExpTyping ftenv tenv fenv (Apply (QF f) (PS (map Val vs))) t).
  econstructor.
  reflexivity.
  auto.
  eauto.
  eapply weakenPrmsTyping in k5.
  instantiate (1:=fenv) in k5.
  instantiate (1:=tenv) in k5.
  instantiate (1:=ftenv) in k5.
  simpl in k5.
  auto.
  constructor.
  auto.

  set (Apply (QF f) (PS (map Val vs))) as e.

  assert (ExpSoundness ftenv tenv fenv e t X3) as X6.
  eapply (ExpEval ftenv tenv fenv e t X3).
  unfold ExpSoundness in X6.
  unfold SoundExp in X6.
  specialize (X6 X0 env k2 s1).
  destruct X6 as [v2 H0 X6].
  destruct X6 as [s2 X6].

  assert (EClosure fenv env (Conf Exp s (Apply (QF f) (PS es)))
                   (Conf Exp s2 (Val v2))).
  eapply EClosConcat.
  exact X1.
  auto.

  assert (s' = s2 /\ v = v2).
  eapply ExpConfluence.
  exact k3.
  auto.
  eauto.
  eauto.
  auto.
  destruct H.
  rewrite H.
  rewrite H1.
  auto.
Defined.

Lemma Apply_BStepT2t
      (ftenv: funTC) (tenv: valTC)
      (fenv: funEnv) (env: valEnv)
      (f: Fun) (es: list Exp) (v: Value) (s s': W)
      (k1: FEnvTyping fenv ftenv)
      (k2: EnvTyping env tenv) (t: VTyp) (pt: PTyp)
      (k3: ExpTyping ftenv tenv fenv (Apply (QF f) (PS es)) t)
      (k0: PrmsTyping ftenv tenv fenv (PS es) pt) :
  EClosure fenv env (Conf Exp s (Apply (QF f) (PS es)))
                                (Conf Exp s' (Val v)) ->
  sigT (fun s1 : W =>
          (sigT2 (fun vs: list Value =>
               (PrmsTyping ftenv tenv fenv (PS (map Val vs)) pt *
               PrmsClosure fenv env (Conf Prms s (PS es))
                                    (Conf Prms s1 (PS (map Val vs))))%type)
            (fun vs : list Value =>
               EClosure fenv env (Conf Exp s1 (Apply (QF f)
                                                  (PS (map Val vs))))
                                 (Conf Exp s' (Val v))))).
Proof.
  intros.
  inversion k3; subst.
  rename X1 into Y2.
  rename X2 into Y1.

  assert (PrmsSoundness ftenv tenv fenv (PS es) (PT (map snd fps)) Y1) as X1.
  eapply (PrmsEval ftenv tenv fenv (PS es) (PT (map snd fps)) Y1).
  unfold PrmsSoundness in X1.
  unfold SoundPrms in X1.
  specialize (X1 k1 env k2 s).
  destruct X1 as [es1 X1].
  destruct X1 as [vs k4 X1].
  destruct X1 as [k5 X1].
  destruct X1 as [s1 X1].

  generalize X1.
  intro.

  eapply Apply1_extended_congruence with (f:=f) in X1.

  econstructor 1 with (x:=s1).

  inversion k4; subst.

  econstructor 1 with (x:=vs).
  split.

  assert (pt = PT (map snd fps)).
  eapply PrmsStrongTyping.
  exact k0.
  auto.
  eauto.
  auto.
  rewrite H.
  auto.

  eapply weakenPrmsTyping in k5.
  instantiate (1:=fenv) in k5.
  instantiate (1:=tenv) in k5.
  instantiate (1:=ftenv) in k5.
  simpl in k5.
  auto.
  constructor.
  auto.

  exact X2.

  assert (ExpTyping ftenv tenv fenv (Apply (QF f) (PS (map Val vs))) t).
  econstructor.
  reflexivity.
  auto.
  eauto.
  eapply weakenPrmsTyping in k5.
  instantiate (1:=fenv) in k5.
  instantiate (1:=tenv) in k5.
  instantiate (1:=ftenv) in k5.
  simpl in k5.
  auto.
  constructor.
  auto.

  set (Apply (QF f) (PS (map Val vs))) as e.

  assert (ExpSoundness ftenv tenv fenv e t X3) as X6.
  eapply (ExpEval ftenv tenv fenv e t X3).
  unfold ExpSoundness in X6.
  unfold SoundExp in X6.
  specialize (X6 X0 env k2 s1).
  destruct X6 as [v2 H0 X6].
  destruct X6 as [s2 X6].

  assert (EClosure fenv env (Conf Exp s (Apply (QF f) (PS es)))
                   (Conf Exp s2 (Val v2))).
  eapply EClosConcat.
  exact X1.
  auto.

  assert (s' = s2 /\ v = v2).
  eapply ExpConfluence.
  exact k3.
  auto.
  eauto.
  eauto.
  auto.
  destruct H.
  rewrite H.
  rewrite H1.
  auto.
Defined.

End Invert.

(*
Lemma BStep_convert
      (fenv: funEnv) (env: valEnv)
      (e1 e2: Exp) (v: Value) (s s': W) :
  forall P,
    (forall
        (w1: forall (fenv: funEnv) (env: valEnv) (e:Exp) (s: W),
             sigT (fun v: Value =>
                 sigT (fun s': W =>
          EClosure fenv env (Conf Exp s e) (Conf Exp s' (Val v)))))
        (w2: forall (e:Exp) (s s1 s2: W) (v1 v2: Value),
           EClosure fenv env (Conf Exp s e) (Conf Exp s1 (Val v1)) ->
           EClosure fenv env (Conf Exp s e) (Conf Exp s2 (Val v2)) ->
           (s1 = s2) /\ (v1 = v2)),
      P fenv env e1 e2 v s s') ->
    (forall
        (ftenv: funTC) (tenv: valTC)
        (k1: FEnvTyping fenv ftenv)
        (k2: EnvTyping env tenv) (t: VTyp)
        (k3: ExpTyping ftenv tenv fenv e1 t),
      P fenv env e1 e2 v s s').
  intros.
  eapply X.
  intros.
  econstructor.
  instantiate (1:= extractRunValue ftenv tenv fenv e1 t k3 k1 env k2 s).
  econstructor.
  instantiate (1:= extractRunState ftenv tenv fenv e1 t k3 k1 env k2 s).
  eapply EvalIntro.
*)


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(*i $Id: Classical_Type.v 14641 2011-11-06 11:59:10Z herbelin $ i*)

(** This file is obsolete, use Classical.v instead *)

(** Classical Logic for Type *)

Require Export Classical_Prop.
Require Export Classical_Pred_Type.


(** In this file, the shape domain of Cosa is defined *)

Require Import Cosa.Lib.Header.
Require Import Cosa.Abstract.NumericalDomain.
Require Import Cosa.Abstract.Lang.
Require Import Cosa.Shape.Summary.
Require Import Cosa.Shape.Graph.
Require Import Cosa.Interaction.Interaction.
Require Import Cosa.Interaction.Rule.
Require Import Cosa.Shape.ShapeDomainSig.

(* WORK IN PROGRESS *)

Section Domain.

  Variable num_dom : NumericalDomain.t Graph.node.
  Variable ind_env : Summary.env.

  (** Domain signature *)
  Record t := {
     carrier :> Type ;
     γ : carrier -> ℘ (cenv*ConcreteFragment.fragment) ;

     inclusion : Rule.rule_set (carrier*carrier) (carrier*carrier) ;
     inclusion_correct : forall g₁ g₂, Proof_of (deductive inclusion) (g₁,g₂) -> γ g₁ ⊆ γ g₂
     (** More operations here. *)
  }.

  (** inclusion is not fully implemented yet. We replace it by a dummy [Rule_set]
      in which there are no proofs. *)
  Definition inclusion_rules {S} : Rule.rule_set S S := {|
    Rule := Empty_set ;
    action := fun magic => match magic with end
  |}.

  Program Definition make : t := {|
     carrier := ShapeDomainSig.t num_dom ind_env ;
     γ := ShapeDomainSig.γ ;

     inclusion := inclusion_rules
  |}.
  Next Obligation. (** inclusion_correct *)
    destruct X.
    simpl in c.
    destruct c as [ [] ? ].
  Qed. (** it is true, though as inclusion is a dummy, irrelevant. *)

End Domain.


From Coq Require Import ZArith List.
From mathcomp Require Import ssreflect ssrbool ssrnat eqtype seq.
From BitBlasting Require Import QFBV CNF BBCommon.
From ssrlib Require Import ZAriths Tactics Bools Seqs.
From nbits Require Import NBits.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

(* ===== bit_blast_signextend ===== *)

Definition bit_blast_signextend n (g: generator) (ls: word) : generator * cnf * word :=
  (g, [::], cat ls (nseq n (msl ls))) .

Definition mk_env_signextend n (E: env) (g: generator) (ls: word) : env * generator * cnf * word :=
  (E, g, [::], cat ls (nseq n (msl ls))) .

Lemma bit_blast_signextend_correct n g bs E ls g' cs lrs :
  bit_blast_signextend n g ls = (g', cs, lrs) ->
  enc_bits E ls bs ->
  interp_cnf E (add_prelude cs) ->
  enc_bits E lrs (sext n bs).
Proof.
  rewrite /bit_blast_signextend.
  case=> _ <- <- /= => Henc Hicnf.
  rewrite /sext.
  rewrite /msl /msb /=.
  move: (add_prelude_enc_bit_ff Hicnf) => Hff.
  move: (enc_bit_lastd Hff Henc) => Hlastd.
  move: Henc (enc_bits_copy n Hlastd).
  exact: enc_bits_cat.
Qed.

Lemma mk_env_signextend_is_bit_blast_signextend n E g ls E' g' cs lrs :
    mk_env_signextend n E g ls = (E', g', cs, lrs) ->
    bit_blast_signextend n g ls = (g', cs, lrs).
Proof.
  rewrite /mk_env_signextend /bit_blast_signextend.
  intros; dcase_hyps.
    by rewrite H0 H1 H2.
Qed.

Lemma mk_env_signextend_newer_gen n E g ls E' g' cs lrs :
    mk_env_signextend n E g ls = (E', g', cs, lrs) ->
    (g <=? g')%positive.
Proof.
  rewrite /mk_env_signextend.
  intros. dcase_hyps; subst.
  exact /Pos.leb_refl.
Qed.

Lemma mk_env_signextend_newer_res n E g ls E' g' cs lrs :
    mk_env_signextend n E g ls = (E', g', cs, lrs) ->
    newer_than_lit g lit_tt ->
    newer_than_lits g ls ->
    newer_than_lits g' lrs.
Proof.
  case=> _ <- _ <- .
  rewrite -newer_than_lit_neg => Hg'ff .
  move=> Hgls.
  rewrite newer_than_lits_cat.
  rewrite -[neg_lit lit_tt]/lit_ff in Hg'ff .
  rewrite /msl /=.
  rewrite (newer_than_lits_copy n (newer_than_lit_lastd Hg'ff Hgls)) .
  by rewrite Hgls.
Qed.

Lemma mk_env_signextend_newer_cnf n E g ls E' g' cs lrs :
    mk_env_signextend n E g ls = (E', g', cs, lrs) ->
    newer_than_lit g lit_tt ->
    newer_than_lits g ls ->
    newer_than_cnf g' cs.
Proof.
    by case=> _ <- <- _ .
Qed.

Lemma mk_env_signextend_preserve n E g ls E' g' cs lrs :
    mk_env_signextend n E g ls = (E', g', cs, lrs) ->
    env_preserve E E' g.
Proof.
    by case=> <- _ _ _ .
Qed.

Lemma mk_env_signextend_sat n E g ls E' g' cs lrs :
    mk_env_signextend n E g ls = (E', g', cs, lrs) ->
    newer_than_lit g lit_tt ->
    newer_than_lits g ls ->
    interp_cnf E' cs.
Proof.
    by case=> <- _ <- _ .
Qed.

Lemma mk_env_signextend_env_equal E1 E2 g n ls E1' E2' g1 g2 cs1 cs2 lrs1 lrs2 :
  env_equal E1 E2 ->
  mk_env_signextend n E1 g ls = (E1', g1, cs1, lrs1) ->
  mk_env_signextend n E2 g ls = (E2', g2, cs2, lrs2) ->
  env_equal E1' E2' /\ g1 = g2 /\ cs1 = cs2 /\ lrs1 = lrs2.
Proof.
  rewrite /mk_env_signextend => Heq.
  case=> ? ? ? ?; case=> ? ? ? ?; subst. done.
Qed.


Set Implicit Arguments.

Section ADTValue.

  Variable ADTValue : Type.

  Require Import Bedrock.Platform.Cito.Transit.
  Require Import Bedrock.Platform.Cito.Semantics.

  Require Import Bedrock.Platform.Cito.Syntax.
  Require Import Bedrock.Platform.Cito.GLabel.
  Require Import Bedrock.Platform.Cito.GLabelMap.
  Import GLabelMap.
  Require Import Bedrock.Platform.Cito.SemanticsExpr.
  Require Import Bedrock.Platform.Cito.GeneralTactics Bedrock.Platform.Cito.GeneralTactics2 Bedrock.Platform.Cito.GeneralTactics3.

  Notation Callee := (@Callee ADTValue).

  Definition Specs := GLabelMap.t Callee.

  Definition f_var := "_f".

  Notation State := (@State ADTValue).

  Definition RunsToDCall specs retvar f args (v v' : State) :=
    match find f specs with
      | Some (Semantics.Foreign spec) =>
        exists inputs outputs ret_w ret_a f_w,
          let vs := upd (fst v) f_var f_w in
          TransitTo spec (List.map (eval vs) args) inputs outputs ret_w ret_a (snd v) (snd v') /\
          fst v' = upd_option vs retvar ret_w
      | _ => True
    end.

  Definition SafeDCall specs f args (v : State) :=
    match find f specs with
      | Some (Semantics.Foreign spec) =>
        forall f_w,
          let vs := upd (fst v) f_var f_w in
          exists inputs, TransitSafe spec (List.map (eval vs) args) inputs (snd v)
      | _ => False
    end.

  (* shallow embedding *)
  Definition assert := Specs -> State -> State -> Prop.
  Definition entailment := Specs -> Prop.

  Inductive StmtEx :=
  | SkipEx : StmtEx
  | SeqEx : StmtEx -> StmtEx -> StmtEx
  | IfEx : Expr -> StmtEx -> StmtEx -> StmtEx
  | WhileEx : assert -> Expr -> StmtEx -> StmtEx
  | AssignEx : string -> Expr -> StmtEx
  | AssertEx : assert -> StmtEx
  | DCallEx : option string -> glabel -> list Expr -> StmtEx.

  Definition and_lift (a b : assert) : assert := fun specs v v' => a specs v v' /\ b specs v v'.
  Definition or_lift (a b : assert) : assert := fun specs v v' => a specs v v' \/ b specs v v'.
  Definition imply_close (a b : assert) : entailment := fun specs => forall v v', a specs v v' -> b specs v v'.

  Infix "/\" := and_lift : assert_scope.
  Infix "\/" := or_lift : assert_scope.
  Infix "-->" := imply_close (at level 90) : assert_scope.

  Close Scope equiv_scope.

  Definition is_true e : assert := fun _ _ v => eval (fst v) e <> $0.
  Definition is_false e : assert := fun _ _ v => eval (fst v) e = $0.

  Open Scope assert_scope.

  Fixpoint to_stmt s :=
    match s with
      | SkipEx => Syntax.Skip
      | SeqEx a b => Syntax.Seq (to_stmt a) (to_stmt b)
      | IfEx e t f => Syntax.If e (to_stmt t) (to_stmt f)
      | WhileEx _ e b => Syntax.While e (to_stmt b)
      | AssignEx x e => Syntax.Assign x e
      | AssertEx _ => Syntax.Skip
      | DCallEx x f args => Syntax.Seq (Syntax.Label f_var f) (Syntax.Call x (Var f_var) args)
    end.

  Coercion to_stmt : StmtEx >-> Stmt.

  Fixpoint sp (stmt : StmtEx) (p : assert) : assert :=
    match stmt with
      | SeqEx a b => sp b (sp a p)
      | IfEx e t f => sp t (p /\ is_true e) \/ sp f (p /\ is_false e)
      | WhileEx inv e _ => inv /\ is_false e
      | AssertEx a => a
      | SkipEx => p
      | AssignEx x e =>
        (fun specs v0 v' =>
           exists v,
             p specs v0 v /\
             v' = (upd (fst v) x (eval (fst v) e), snd v))%type
      | DCallEx x f args =>
        (fun specs v0 v' =>
           exists v,
             p specs v0 v /\
             RunsToDCall specs x f args v v')%type
    end.

  Fixpoint vc stmt (p : assert) : list entailment :=
    match stmt with
      | SeqEx a b => vc a p ++ vc b (sp a p)
      | IfEx e t f => vc t (p /\ is_true e) ++ vc f (p /\ is_false e)
      | WhileEx inv e body =>
        (p --> inv) :: (sp body (inv /\ is_true e) --> inv) :: vc body (inv /\ is_true e)
      | AssertEx a => (p --> a) :: nil
      | SkipEx => nil
      | AssignEx _ _ => nil
      | DCallEx x f args => (p --> (fun specs _ v => SafeDCall specs f args v)) :: nil
    end.

  Definition and_all : list entailment -> entailment := fold_right (fun a b specs => a specs /\ b specs)%type (fun _ => True).

  Lemma and_all_app : forall ls1 ls2 specs, and_all (ls1 ++ ls2) specs -> and_all ls1 specs /\ and_all ls2 specs.
    induction ls1; simpl; intuition.
    eapply IHls1 in H1; openhyp; eauto.
    eapply IHls1 in H1; openhyp; eauto.
  Qed.

  Lemma is_true_intro : forall e specs v v', wneb (eval (fst v') e) $0 = true -> (is_true e) specs v v'.
    intros.
    unfold is_true.
    unfold wneb in *.
    destruct (weq _ _) in *; intuition.
  Qed.

  Hint Resolve is_true_intro.

  Lemma is_false_intro : forall e specs v v', wneb (eval (fst v') e) $0 = false -> (is_false e) specs v v'.
    intros.
    unfold is_false.
    unfold wneb in *.
    destruct (weq _ _) in *; intuition.
  Qed.

  Hint Resolve is_false_intro.

  Hint Constructors Semantics.RunsTo.
  Hint Constructors Semantics.Safe.

  Ltac inject :=
    match goal with
      | H : _ = _ |- _ => unfold_all; injection H; intros; subst
    end.

  Definition Env := ((glabel -> option W) * (W -> option Callee))%type.

  Open Scope type.

  Definition specs_fs_agree (specs : Specs) (env : Env) :=
    let labels := fst env in
    let fs := snd env in
    forall p spec,
      fs p = Some spec <->
      exists (lbl : glabel),
        labels lbl = Some p /\
        find lbl specs = Some spec.

  Definition labels_in_scope (specs : Specs) (labels : glabel -> option W) :=
    forall lbl, In lbl specs -> labels lbl <> None.

  Definition specs_stn_injective (specs : Specs) stn := forall lbl1 lbl2 (w : W), In lbl1 specs -> In lbl2 specs -> stn lbl1 = Some w -> stn lbl2 = Some w -> lbl1 = lbl2.

  Definition specs_env_agree (specs : Specs) (env : Env) :=
    labels_in_scope specs (fst env) /\
    specs_stn_injective specs (fst env) /\
    specs_fs_agree specs env.

  Require Import Bedrock.Platform.Cito.GLabelMapFacts.
  Require Import Bedrock.Platform.Cito.Option.

  Require Import Bedrock.Platform.Cito.BedrockTactics.

  Lemma RunsTo_RunsToDCall :
    forall specs env r f args v v',
      specs_env_agree specs env ->
      RunsTo env (DCallEx r f args) v v' ->
      RunsToDCall specs r f args v v'.
  Proof.
    intros.
    simpl in *.
    unfold RunsToDCall.
    inv_clear H0.
    inv_clear H3.
    destruct (option_dec(find f specs)).
    destruct s; rewrite e; simpl in *.
    destruct x; simpl in *.
    destruct H; simpl in *.
    destruct env; simpl in *.
    rename a into f0.
    assert (o0 w = Some (Foreign f0)).
    eapply H0.
    descend; eauto.
    generalize H6; intro HH.
    inv_clear H6; simpl in *.
    sel_upd_simpl; rewrite H7 in H1; discriminate.
    sel_upd_simpl; rewrite H7 in H1; injection H1; intros; subst.
    eapply RunsTo_TransitTo in HH.
    Focus 2.
    simpl; sel_upd_simpl; eauto.
    openhyp.
    destruct r; simpl in *.
    subst; simpl in *.
    descend.
    eauto.
    sel_upd_simpl; eauto.
    descend.
    eauto.
    eauto.
    eauto.
    rewrite e; eauto.
  Qed.

  Lemma SafeDCall_Safe :
    forall specs env r f args v,
      specs_env_agree specs env ->
      SafeDCall specs f args v ->
      Safe env (DCallEx r f args) v.
  Proof.
    intros.
    destruct H.
    destruct env; simpl in *.
    unfold SafeDCall in *.
    destruct (option_dec(find f specs)).
    destruct s; rewrite e in *; simpl in *.
    destruct x.
    econstructor.
    econstructor.
    eapply H.
    eapply MapsTo_In; eapply find_mapsto_iff; eauto.
    intros.
    inv_clear H2.
    specialize (H0 w); clear H.
    destruct H0 as [inputs Htsf].
    eapply TransitSafe_Safe; eauto.
    sel_upd_simpl.
    eapply H1.
    descend; eauto.
    intuition.
    rewrite e in *; eauto.
    intuition.
  Qed.

  Lemma sound_runsto' : forall env (s : Stmt) v v', RunsTo env s v v' -> forall s' : StmtEx, s = s' -> forall specs, specs_env_agree specs env -> forall p, and_all (vc s' p) specs -> forall v0, p specs v0 v -> (sp s' p) specs v0 v'.
    induction 1; simpl; intros; destruct s'; try discriminate; simpl in *; try inject.

    (* skip *)
    eauto.

    openhyp.
    eauto.

    (* seq *)
    eapply_in_any and_all_app; openhyp.
    eauto.

    (* call *)
    openhyp.
    descend.
    eauto.
    eapply RunsTo_RunsToDCall; simpl; eauto.

    (* if *)
    eapply_in_any and_all_app; openhyp.
    left.
    eapply IHRunsTo; eauto.
    split; eauto.

    eapply_in_any and_all_app; openhyp.
    right.
    eapply IHRunsTo; eauto.
    split; eauto.

    (* while *)
    openhyp.
    eapply (IHRunsTo2 (WhileEx _ e s')); simpl in *; eauto.
    eapply IHRunsTo1; simpl in *; eauto.
    split; eauto.

    openhyp.
    split; eauto.

    (* assign *)
    descend; eauto.
  Qed.

  Theorem sound_runsto : forall env (s : StmtEx) v v' specs p, RunsTo env s v v' -> specs_env_agree specs env -> and_all (vc s p) specs -> p specs v v -> (sp s p) specs v v'.
    intros.
    eapply sound_runsto'; eauto.
  Qed.

  Close Scope assert_scope.

  Theorem sound_safe : forall specs env (s : Stmt) (s' : StmtEx) v p v0, s = s' -> specs_env_agree specs env -> and_all (vc s' p) specs -> p specs v0 v -> Safe env s v.
    intros.
    eapply (Safe_coind (fun s v => Safe env s v \/ exists (s' : StmtEx) p v0, s = s' /\ and_all (vc s' p) specs /\ p specs v0 v)); [ .. | right; descend; eauto]; generalize H0; clear; intros; openhyp.

    (* seq *)
    inversion H; subst.
    descend; left; eauto.

    destruct x; try discriminate; simpl in *; try inject.
    eapply_in_any and_all_app; openhyp.
    descend.
    right; descend; eauto.
    intros.
    eapply sound_runsto' with (p := x0) in H4; eauto.
    right; descend; eauto.

    (* dcall *)

    openhyp.
    eapply H1 in H2.
    eapply SafeDCall_Safe in H2; eauto.
    simpl in *.
    inv_clear H2.
    split.
    eauto.
    intros.
    eauto.

    (* if *)
    inversion H; subst.
    openhyp; subst.
    left; descend.
    eauto.
    left; eauto.
    right; descend.
    eauto.
    left; eauto.

    destruct x; try discriminate; simpl in *; try inject.
    eapply_in_any and_all_app; openhyp.
    unfold wneb.
    destruct (weq (eval (fst v) e) $0) in *.
    right.
    descend; eauto.
    right; descend; eauto.
    split; eauto.
    left.
    descend; eauto.
    right; descend; eauto.
    split; eauto.

    (* while *)
    inversion H; unfold_all; subst.
    left; descend.
    eauto.
    left; eauto.
    left; eauto.
    right; eauto.

    destruct x; try discriminate; simpl in *; try inject.
    openhyp.
    unfold wneb.
    destruct (weq (eval (fst v) e) $0) in *.
    right.
    eauto.
    left.
    descend; eauto.
    right.
    descend; eauto.
    split; eauto.
    right.
    eapply sound_runsto' with (p := and_lift a (is_true e)) in H5; eauto.
    descend.
    instantiate (1 := WhileEx _ e x).
    eauto.
    2 : eauto.
    simpl.
    descend; eauto.
    split; eauto.

    (* call *)
    inversion H; unfold_all; subst.
    left; descend; eauto.
    right; descend; eauto.

    destruct x; try discriminate; simpl in *; try inject.

    (* label *)
    inversion H; unfold_all; subst.
    eauto.

    destruct x0; try discriminate; simpl in *; try inject.
  Qed.

End ADTValue.


Require Import OrderedTypeEx.
Require Import StoreIface.
Require Import BasicMachineTypes.
Require Import AnnotationIface.
Require Import List.
Require Import ZArith.

Module Type CLASSDATATYPES
  (C_B : BASICS)
  (C_A : ANNOTATION C_B).

(***************************
 * Various notions of type
 ***************************)
Inductive array_type : Set :=
 aty_boolean | aty_char | aty_float | aty_double | aty_byte | aty_short | aty_int | aty_long : array_type.

Inductive stack_type : Set :=
 sty_int | sty_long | sty_double | sty_float | sty_addr.

Inductive java_type : Set :=
| ty_byte
| ty_char
| ty_double
| ty_float
| ty_int
| ty_long
| ty_boolean
| ty_short : java_type
| ty_ref : java_ref_type -> java_type
with java_ref_type : Set :=
| ty_obj : C_B.Classname.t -> java_ref_type
| ty_arr : java_type -> java_ref_type.

Declare Module JavaType_as_UOT : UsualOrderedType with Definition t := java_type.

Inductive value_category : Set := category1 | category2.

Definition java_type_category : java_type -> value_category :=
  fun ty => match ty with
  | ty_byte => category1
  | ty_char => category1
  | ty_short => category1
  | ty_boolean => category1
  | ty_int => category1
  | ty_float => category1
  | ty_ref _ => category1
  | ty_double => category2
  | ty_long => category2
  end.

Definition stack_type_category : stack_type -> value_category :=
  fun ty => match ty with
  | sty_int => category1
  | sty_float => category1
  | sty_double => category2
  | sty_addr => category1
  | sty_long => category2
  end.

(**********************
 * The instructions
 **********************)

(* Constants *)
Inductive double_constant : Set := d0 | d1 : double_constant.
Inductive float_constant : Set := f0 | f1 | f2 : float_constant.
Inductive long_constant : Set := l0 | l1 : long_constant.

(* Comparison operations *)
Inductive acmp : Set := acmp_eq | acmp_ne : acmp.
Inductive cmp : Set := cmp_eq | cmp_ne | cmp_lt | cmp_ge | cmp_gt | cmp_le : cmp.
Inductive float_cmp_opt : Set := fcmp_l | fcmp_g : float_cmp_opt.

(* Arithmetic operations *)
Inductive integer_bop : Set :=
 iadd | idiv | iand | imul | ior | irem | ishl | ishr | isub | iushr | ixor : integer_bop.

Inductive integer_uop : Set :=
 ineg : integer_uop.

Inductive float_bop : Set :=
 fadd | fdiv | fmul | frem | fsub : float_bop.

Inductive float_uop : Set :=
 fneg : float_uop.

Inductive opcode : Set :=
(* Arithmetic *)
| op_iarithb : integer_bop -> opcode
| op_iarithu : integer_uop -> opcode
| op_larithb : integer_bop -> opcode
| op_larithu : integer_uop -> opcode
| op_iinc    : nat -> C_B.Int32.t -> opcode
| op_darithb : float_bop -> opcode
| op_darithu : float_uop -> opcode
| op_farithb : float_bop -> opcode
| op_farithu : float_uop -> opcode

(* Stack Operations *)
| op_dup     : opcode
| op_dup_x1  : opcode
| op_dup_x2  : opcode
| op_dup2    : opcode
| op_dup2_x1 : opcode
| op_dup2_x2 : opcode
| op_nop     : opcode
| op_pop     : opcode
| op_pop2    : opcode
| op_swap    : opcode

(* Local Variables *)
| op_load   : stack_type -> nat -> opcode
| op_store  : stack_type -> nat -> opcode

(* OO *)
| op_instanceof      : C_B.ConstantPoolRef.t -> opcode
| op_invokeinterface : C_B.ConstantPoolRef.t -> opcode
| op_invokespecial   : C_B.ConstantPoolRef.t -> opcode
| op_invokestatic    : C_B.ConstantPoolRef.t -> opcode
| op_invokevirtual   : C_B.ConstantPoolRef.t -> opcode
| op_aconst_null     : opcode
| op_checkcast       : C_B.ConstantPoolRef.t -> opcode
| op_getfield        : C_B.ConstantPoolRef.t -> opcode
| op_getstatic       : C_B.ConstantPoolRef.t -> opcode
| op_new             : C_B.ConstantPoolRef.t -> opcode
| op_putfield        : C_B.ConstantPoolRef.t -> opcode
| op_putstatic       : C_B.ConstantPoolRef.t -> opcode

(* Comparisons and flow control *)
| op_if_acmp : acmp -> Z -> opcode
| op_if_icmp : cmp -> Z -> opcode
| op_if      : cmp -> Z -> opcode
| op_ifnonnull : Z -> opcode
| op_ifnull  : Z -> opcode
| op_goto    : Z -> opcode
| op_valreturn : stack_type -> opcode
| op_return  : opcode
| op_athrow  : opcode
| op_dcmp    : float_cmp_opt -> opcode
| op_fcmp    : float_cmp_opt -> opcode
| op_lcmp    : opcode
| op_lookupswitch : Z -> Z -> list (Z * Z) -> opcode
| op_tableswitch : Z -> Z -> Z -> list Z -> opcode

(* Arrays *)
| op_iaload  : opcode
| op_iastore : opcode
| op_aaload  : opcode
| op_aastore : opcode
| op_anewarray : C_B.ConstantPoolRef.t -> opcode
| op_arraylength : opcode
| op_baload  : opcode
| op_bastore : opcode
| op_caload  : opcode
| op_castore : opcode
| op_daload  : opcode
| op_dastore : opcode
| op_faload  : opcode
| op_fastore : opcode
| op_laload  : opcode
| op_lastore : opcode
| op_multianewarray : C_B.ConstantPoolRef.t -> nat -> opcode
| op_newarray : array_type -> opcode
| op_saload  : opcode
| op_sastore : opcode

(* Constants *)
| op_iconst : C_B.Int32.t -> opcode
| op_dconst : double_constant -> opcode
| op_fconst : float_constant -> opcode
| op_lconst : long_constant -> opcode
| op_ldc    : C_B.ConstantPoolRef.t -> opcode
| op_ldc2   : C_B.ConstantPoolRef.t -> opcode

(* Concurrency *)
| op_monitorenter : opcode
| op_monitorexit  : opcode

(* Conversions *)
| op_i2b    : opcode
| op_i2c    : opcode
| op_i2d    : opcode
| op_i2f    : opcode
| op_i2l    : opcode
| op_i2s    : opcode
| op_d2f    : opcode
| op_d2i    : opcode
| op_d2l    : opcode
| op_f2d    : opcode
| op_f2i    : opcode
| op_f2l    : opcode
| op_l2d    : opcode
| op_l2f    : opcode
| op_l2i    : opcode.

(*************************
 * Some functions for dealing with the program counter
 *************************)
Parameter pc_plus_offset : nat -> Z -> option nat.
(* for checking if the current program counter is in the range of an exception handler *)
Parameter is_within : forall s e p, ({p >= s /\ p < e} + {p < s \/ p >= e})%nat.

(*************************
 * The structure of classes
 *************************)
Record descriptor : Set := mkDescriptor
 { descriptor_ret_type : option java_type
 ; descriptor_arg_types : list java_type
 }.

Declare Module Descriptor_as_UOT : UsualOrderedType with Definition t := descriptor.

Record exception_handler : Set := mkExcHandler
  { exc_start_pc : nat
  ; exc_end_pc   : nat
  ; exc_handler_pc : nat
  ; exc_catch_type : option C_B.ConstantPoolRef.t
  }.

Record precode : Type := mkPreCode
  { precode_max_stack       : nat
  ; precode_max_lvars       : nat
  ; precode_code            : list opcode            (* FIXME: need a better representation than lists *)
  ; precode_exception_table : list exception_handler
  ; precode_annot           : C_A.code_annotation
  }. (* + certificate *)

Record code : Set := mkCode
  { code_max_stack       : nat
  ; code_max_lvars       : nat
  ; code_code            : list opcode            (* FIXME: need a better representation than lists *)
  ; code_exception_table : list exception_handler
  }. (* + certificate *)

Record premethod : Type := mkPreMethod
  { premethod_name         : C_B.Methodname.t
  ; premethod_descriptor   : descriptor
  ; premethod_public       : bool
  ; premethod_protected    : bool
  ; premethod_private      : bool
  ; premethod_abstract     : bool (* if this is false, and the code does not exist, then the method is native *)
  ; premethod_static       : bool
  ; premethod_final        : bool
  ; premethod_synchronized : bool
  ; premethod_strict       : bool
  ; premethod_code         : option precode
  ; premethod_annot        : C_A.method_annotation
  }. (* + attributes *)

Record method : Type := mkMethod
  { method_name         : C_B.Methodname.t
  ; method_descriptor   : descriptor
  ; method_public       : bool
  ; method_protected    : bool
  ; method_private      : bool
  ; method_abstract     : bool (* if this is false, and the code does not exist, then the method is native *)
  ; method_static       : bool
  ; method_final        : bool
  ; method_synchronized : bool
  ; method_strict       : bool
  ; method_code         : option code
  ; method_annot        : C_A.method_annotation
  }. (* + attributes *)

Declare Module MethodList : STORE with Definition key := (C_B.Methodname.t * descriptor)%type
                                  with Definition object := method
                                  with Definition Key.eq := (@eq (C_B.Methodname.t * descriptor)).

Record field : Set := mkField
  { field_name      : C_B.Fieldname.t
  ; field_type      : java_type
  ; field_public    : bool
  ; field_private   : bool
  ; field_protected : bool
  ; field_static    : bool
  ; field_final     : bool
  ; field_volatile  : bool
  ; field_transient : bool
  }. (* + attributes (ConstantValue) *)

Declare Module FieldList : STORE with Definition key := (C_B.Fieldname.t * java_type)%type
                                 with Definition object := field.

Inductive constantpool_entry : Set :=
| cpe_methodref : C_B.Classname.t -> C_B.Methodname.t -> descriptor -> constantpool_entry
| cpe_interfacemethodref : C_B.Classname.t -> C_B.Methodname.t -> descriptor -> constantpool_entry
| cpe_fieldref  : C_B.Classname.t -> C_B.Fieldname.t -> java_type -> constantpool_entry
| cpe_int       : C_B.Int32.t -> constantpool_entry
| cpe_classref  : C_B.Classname.t -> constantpool_entry
| cpe_other     : constantpool_entry.

Declare Module ConstantPool : STORE with Definition key := C_B.ConstantPoolRef.t
                                    with Definition object := constantpool_entry.

Record preclass : Type := mkPreClass
  { preclass_name         : C_B.Classname.t
  ; preclass_super_name   : option C_B.Classname.t
  ; preclass_super_interfaces : list C_B.Classname.t
  ; preclass_public       : bool
  ; preclass_final        : bool
  ; preclass_super        : bool
  ; preclass_interface    : bool
  ; preclass_abstract     : bool
  ; preclass_methods      : list premethod
  ; preclass_fields       : FieldList.t
  ; preclass_constantpool : ConstantPool.t
  ; preclass_annotation   : C_A.class_annotation
  }. (* + attributes *)

Record class : Type := mkClass
  { class_name         : C_B.Classname.t
  ; class_super_class  : option C_B.Classname.t
  ; class_interfaces   : list C_B.Classname.t
  ; class_public       : bool
  ; class_final        : bool
  ; class_super        : bool
  ; class_interface    : bool
  ; class_abstract     : bool
  ; class_methods      : MethodList.t
  ; class_fields       : FieldList.t
  ; class_constantpool : ConstantPool.t
  }. (* + attributes *)

Inductive has_premethod : list premethod -> C_B.Methodname.t * descriptor -> premethod -> Prop :=
| has_premethod_cons_1 : forall nm d public protected private abstract static final synchronized strict code annot meths,
   has_premethod (mkPreMethod nm d public protected private abstract static final synchronized strict code annot::meths)
                 (nm,d)
                 (mkPreMethod nm d public protected private abstract static final synchronized strict code annot)
| has_premethod_cons_2 : forall nm d public protected private abstract static final synchronized strict code annot meths nm' d' m,
   has_premethod meths (nm',d') m ->
   (nm <> nm' \/ d <> d') ->
   has_premethod (mkPreMethod nm d public protected private abstract static final synchronized strict code annot::meths)
                 (nm',d')
                 m.

Hypothesis has_premethod_dec : forall ms mdesc,
 (exists m, has_premethod ms mdesc m)\/(forall m, ~has_premethod ms mdesc m).

Hypothesis has_premethod_functional : forall ms mdesc mA mB,
 has_premethod ms mdesc mA ->
 has_premethod ms mdesc mB ->
 mA = mB.

Hypothesis has_premethod_in : forall ms m,
  has_premethod ms (premethod_name m, premethod_descriptor m) m ->
  In m ms.

Hypothesis has_premethod_name : forall ms md m,
  has_premethod ms md m -> md = (premethod_name m, premethod_descriptor m).
Implicit Arguments has_premethod_name [ms md m].

End CLASSDATATYPES.


(** * Induced functors between comma categories *)
Require Import Category.Core Functor.Core NaturalTransformation.Core.
Require Import Category.Dual.
Require Import Category.Prod.
Require Import NaturalTransformation.Identity.
Require Import FunctorCategory.Core Cat.Core.
Require Import InitialTerminalCategory.Core InitialTerminalCategory.Functors.
Require Comma.Core.
Local Set Warnings Append "-notation-overridden". (* work around bug #5567, https://coq.inria.fr/bugs/show_bug.cgi?id=5567, notation-overridden,parsing should not trigger for only printing notations *)
Import Comma.Core.
Local Set Warnings Append "notation-overridden".
Require Import Comma.Projection.
Require Import Types.Prod HoTT.Tactics Types.Unit.

Set Universe Polymorphism.
Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.

Local Open Scope functor_scope.
Local Open Scope category_scope.

(** ** Morphisms in [(A → C)ᵒᵖ × (B → C)] from [(s₀, s₁)] to [(d₀, d₁)] induce functors [(s₀ / s₁) → (d₀ / d₁)] *)
Section comma_category_induced_functor.
  Context `{Funext}.
  Variables A B C : PreCategory.

  Definition comma_category_induced_functor_object_of s d
             (m : morphism ((A -> C)^op * (B -> C)) s d)
             (x : fst s / snd s)
  : (fst d / snd d)
    := CommaCategory.Build_object
         (fst d) (snd d)
         (CommaCategory.a x)
         (CommaCategory.b x)
         ((snd m) (CommaCategory.b x) o CommaCategory.f x o (fst m) (CommaCategory.a x)).

  Lemma comma_category_induced_functor_object_of_identity s x
  : comma_category_induced_functor_object_of (Category.Core.identity s) x
    = x.
  Proof.
    let x1 := match goal with |- ?x1 = ?x2 => constr:(x1) end in
    let x2 := match goal with |- ?x1 = ?x2 => constr:(x2) end in
    apply (CommaCategory.path_object' x1 x2 idpath idpath).
    simpl.
    abstract (rewrite ?left_identity, ?right_identity; reflexivity).
  Defined.

  Definition comma_category_induced_functor_object_of_compose s d d'
             (m : morphism ((A -> C)^op * (B -> C)) d d')
             (m' : morphism ((A -> C)^op * (B -> C)) s d)
             x
  : comma_category_induced_functor_object_of (m o m') x
    = comma_category_induced_functor_object_of
        m
        (comma_category_induced_functor_object_of m' x).
  Proof.
    let x1 := match goal with |- ?x1 = ?x2 => constr:(x1) end in
    let x2 := match goal with |- ?x1 = ?x2 => constr:(x2) end in
    apply (CommaCategory.path_object' x1 x2 idpath idpath).
    abstract (
        destruct m', m, x;
        simpl in *;
          rewrite !associativity;
        reflexivity
      ).
  Defined.

  Definition comma_category_induced_functor_morphism_of s d m s0 d0
             (m0 : morphism (fst s / snd s) s0 d0)
  : morphism (fst d / snd d)
             (@comma_category_induced_functor_object_of s d m s0)
             (@comma_category_induced_functor_object_of s d m d0).
  Proof.
    simpl.
    let s := match goal with |- CommaCategory.morphism ?s ?d => constr:(s) end in
    let d := match goal with |- CommaCategory.morphism ?s ?d => constr:(d) end in
    refine (CommaCategory.Build_morphism s d (CommaCategory.g m0) (CommaCategory.h m0) _);
      simpl in *; clear.
    abstract (
        destruct_head prod;
        destruct_head CommaCategory.morphism;
        destruct_head CommaCategory.object;
        simpl in *;
          repeat (try_associativity_quick (rewrite <- !commutes || (progress f_ap)));
        repeat (try_associativity_quick (rewrite !commutes || (progress f_ap)));
        assumption
      ). (* 3.495 s *)
  Defined.

  Definition comma_category_induced_functor s d
             (m : morphism ((A -> C)^op * (B -> C)) s d)
  : Functor (fst s / snd s) (fst d / snd d).
  Proof.
    refine (Build_Functor (fst s / snd s) (fst d / snd d)
                          (@comma_category_induced_functor_object_of s d m)
                          (@comma_category_induced_functor_morphism_of s d m)
                          _
                          _
           );
    abstract (
        intros; apply CommaCategory.path_morphism; reflexivity
      ).
  Defined.
End comma_category_induced_functor.

(** ** Morphisms in [C] from [a] to [a'] induce functors [(C / a) → (C / a')] *)
Section slice_category_induced_functor.
  Context `{Funext}.
  Variable C : PreCategory.

  Section slice_coslice.
    Variable D : PreCategory.

    (** TODO(JasonGross): See if this can be recast as an exponential law functor about how [1 → Cat] is isomorphic to [Cat], or something *)
    Definition slice_category_induced_functor_nt s d (m : morphism D s d)
    : NaturalTransformation !s !d.
    Proof.
      exists (fun _ : Unit => m);
      simpl; intros; clear;
      abstract (autorewrite with category; reflexivity).
    Defined.

    Variable F : Functor C D.
    Variable a : D.

    Section slice.
      Definition slice_category_induced_functor F' a'
                 (m : morphism D a a')
                 (T : NaturalTransformation F' F)
      : Functor (F / a) (F' / a')
        := comma_category_induced_functor
             (s := (F, !a))
             (d := (F', !a'))
             (T, @slice_category_induced_functor_nt a a' m).

      Definition slice_category_nt_induced_functor F' T
        := @slice_category_induced_functor F' a 1 T.
      Definition slice_category_morphism_induced_functor a' m
        := @slice_category_induced_functor F a' m 1.
    End slice.

    Section coslice.
      Definition coslice_category_induced_functor F' a'
                 (m : morphism D a' a)
                 (T : NaturalTransformation F F')
      : Functor (a / F) (a' / F')
        := comma_category_induced_functor
             (s := (!a, F))
             (d := (!a', F'))
             (@slice_category_induced_functor_nt a' a m, T).

      Definition coslice_category_nt_induced_functor F' T
        := @coslice_category_induced_functor F' a 1 T.
      Definition coslice_category_morphism_induced_functor a' m
        := @coslice_category_induced_functor F a' m 1.
    End coslice.
  End slice_coslice.

  Definition slice_category_over_induced_functor a a' (m : morphism C a a')
  : Functor (C / a) (C / a')
    := Eval hnf in slice_category_morphism_induced_functor _ _ _ m.
  Definition coslice_category_over_induced_functor a a' (m : morphism C a' a)
  : Functor (a \ C) (a' \ C)
    := Eval hnf in coslice_category_morphism_induced_functor _ _ _ m.
End slice_category_induced_functor.

(** ** Functors [A → A'] functors [(cat / A) → (cat / A')] *)
Section cat_over_induced_functor.
  Context `{Funext}.
  Variable P : PreCategory -> Type.
  Context `{H0 : forall C D, P C -> P D -> IsHSet (Functor C D)}.

  Local Notation cat := (@sub_pre_cat _ P H0).

  Definition cat_over_induced_functor a a' (m : morphism cat a a')
  : Functor (cat / a) (cat / a')
    := slice_category_over_induced_functor cat a a' m.

  Definition over_cat_induced_functor a a' (m : morphism cat a' a)
  : Functor (a \ cat) (a' \ cat)
    := coslice_category_over_induced_functor cat a a' m.
End cat_over_induced_functor.


From iris.algebra Require Import gset coPset.
From iris.proofmode Require Import tactics.
From iris.base_logic.lib Require Export invariants.
From iris.prelude Require Import options.
Import uPred.

(* Non-atomic ("thread-local") invariants. *)

Definition na_inv_pool_name := gname.

Class na_invG Σ :=
  na_inv_inG :> inG Σ (prodR coPset_disjR (gset_disjR positive)).
Definition na_invΣ : gFunctors :=
  #[ GFunctor (constRF (prodR coPset_disjR (gset_disjR positive))) ].
Global Instance subG_na_invG {Σ} : subG na_invΣ Σ → na_invG Σ.
Proof. solve_inG. Qed.

Section defs.
  Context `{!invG Σ, !na_invG Σ}.

  Definition na_own (p : na_inv_pool_name) (E : coPset) : iProp Σ :=
    own p (CoPset E, GSet ∅).

  Definition na_inv (p : na_inv_pool_name) (N : namespace) (P : iProp Σ) : iProp Σ :=
    (∃ i, ⌜i ∈ (↑N:coPset)⌝ ∧
          inv N (P ∗ own p (CoPset ∅, GSet {[i]}) ∨ na_own p {[i]}))%I.
End defs.

Global Instance: Params (@na_inv) 3 := {}.
Typeclasses Opaque na_own na_inv.

Section proofs.
  Context `{!invG Σ, !na_invG Σ}.

  Global Instance na_own_timeless p E : Timeless (na_own p E).
  Proof. rewrite /na_own; apply _. Qed.

  Global Instance na_inv_ne p N : NonExpansive (na_inv p N).
  Proof. rewrite /na_inv. solve_proper. Qed.
  Global Instance na_inv_proper p N : Proper ((≡) ==> (≡)) (na_inv p N).
  Proof. apply (ne_proper _). Qed.

  Global Instance na_inv_persistent p N P : Persistent (na_inv p N P).
  Proof. rewrite /na_inv; apply _. Qed.

  Lemma na_inv_iff p N P Q : na_inv p N P -∗ ▷ □ (P ↔ Q) -∗ na_inv p N Q.
  Proof.
    iIntros "HI #HPQ". rewrite /na_inv. iDestruct "HI" as (i ?) "HI".
    iExists i. iSplit; first done. iApply (inv_iff with "HI").
    iIntros "!> !>".
    iSplit; iIntros "[[? Ho]|$]"; iLeft; iFrame "Ho"; by iApply "HPQ".
  Qed.

  Lemma na_alloc : ⊢ |==> ∃ p, na_own p ⊤.
  Proof. by apply own_alloc. Qed.

  Lemma na_own_disjoint p E1 E2 : na_own p E1 -∗ na_own p E2 -∗ ⌜E1 ## E2⌝.
  Proof.
    apply wand_intro_r.
    rewrite /na_own -own_op own_valid -coPset_disj_valid_op. by iIntros ([? _]).
  Qed.

  Lemma na_own_union p E1 E2 :
    E1 ## E2 → na_own p (E1 ∪ E2) ⊣⊢ na_own p E1 ∗ na_own p E2.
  Proof.
    intros ?. by rewrite /na_own -own_op -pair_op left_id coPset_disj_union.
  Qed.

  Lemma na_own_acc E2 E1 tid :
    E2 ⊆ E1 → na_own tid E1 -∗ na_own tid E2 ∗ (na_own tid E2 -∗ na_own tid E1).
  Proof.
    intros HF. assert (E1 = E2 ∪ (E1 ∖ E2)) as -> by exact: union_difference_L.
    rewrite na_own_union; last by set_solver+. iIntros "[$ $]". auto.
  Qed.

  Lemma na_inv_alloc p E N P : ▷ P ={E}=∗ na_inv p N P.
  Proof.
    iIntros "HP".
    iMod (own_unit (prodUR coPset_disjUR (gset_disjUR positive)) p) as "Hempty".
    iMod (own_updateP with "Hempty") as ([m1 m2]) "[Hm Hown]".
    { apply prod_updateP'.
      - apply cmra_updateP_id, (reflexivity (R:=eq)).
      - apply (gset_disj_alloc_empty_updateP_strong' (λ i, i ∈ (↑N:coPset))).
        intros Ef. exists (coPpick (↑ N ∖ gset_to_coPset Ef)).
        rewrite -elem_of_gset_to_coPset comm -elem_of_difference.
        apply coPpick_elem_of=> Hfin.
        eapply nclose_infinite, (difference_finite_inv _ _), Hfin.
        apply gset_to_coPset_finite. }
    simpl. iDestruct "Hm" as %(<- & i & -> & ?).
    rewrite /na_inv.
    iMod (inv_alloc N with "[-]"); last (iModIntro; iExists i; eauto).
    iNext. iLeft. by iFrame.
  Qed.

  Lemma na_inv_acc p E F N P :
    ↑N ⊆ E → ↑N ⊆ F →
    na_inv p N P -∗ na_own p F ={E}=∗ ▷ P ∗ na_own p (F∖↑N) ∗
                       (▷ P ∗ na_own p (F∖↑N) ={E}=∗ na_own p F).
  Proof.
    rewrite /na_inv. iIntros (??) "#Hnainv Htoks".
    iDestruct "Hnainv" as (i) "[% Hinv]".
    rewrite [F as X in na_own p X](union_difference_L (↑N) F) //.
    rewrite [X in (X ∪ _)](union_difference_L {[i]} (↑N)) ?na_own_union; [|set_solver..].
    iDestruct "Htoks" as "[[Htoki $] $]".
    iInv "Hinv" as "[[$ >Hdis]|>Htoki2]" "Hclose".
    - iMod ("Hclose" with "[Htoki]") as "_"; first auto.
      iIntros "!> [HP $]".
      iInv N as "[[_ >Hdis2]|>Hitok]".
      + iDestruct (own_valid_2 with "Hdis Hdis2") as %[_ Hval%gset_disj_valid_op].
        set_solver.
      + iSplitR "Hitok"; last by iFrame. eauto with iFrame.
    - iDestruct (na_own_disjoint with "Htoki Htoki2") as %?. set_solver.
  Qed.

  Global Instance into_inv_na p N P : IntoInv (na_inv p N P) N := {}.

  Global Instance into_acc_na p F E N P :
    IntoAcc (X:=unit) (na_inv p N P)
            (↑N ⊆ E ∧ ↑N ⊆ F) (na_own p F) (fupd E E) (fupd E E)
            (λ _, ▷ P ∗ na_own p (F∖↑N))%I (λ _, ▷ P ∗ na_own p (F∖↑N))%I
              (λ _, Some (na_own p F))%I.
  Proof.
    rewrite /IntoAcc /accessor. iIntros ((?&?)) "#Hinv Hown".
    rewrite exist_unit -assoc /=.
    iApply (na_inv_acc with "Hinv"); done.
  Qed.
End proofs.


Require Import GHC.Base.
Require Import Proofs.GHC.Base.
Require Import Data.Ord.

From Coq Require Import ssreflect ssrbool ssrfun.
Set Bullet Behavior "Strict Subproofs".

Instance EqLaws_Down {a} `{EqLaws a} : EqLaws (Down a).
Proof.
  split;
  unfold op_zeze__, op_zsze__;
  unfold Ord.Eq___Down;
  unfold op_zeze____, op_zsze____;
  unfold Ord.Eq___Down_op_zsze__;
  unfold Ord.Eq___Down_op_zeze__;
  unfold coerce, Coercible_Unpeel, unpeel, repeel, Unpeel_refl;
  unfold "_==_";
  unfold "_/=_".

  - case=> * /=; apply Eq_refl.
  - do 2 case=> ? //=; apply Eq_sym.
  - do 3 case=> ? //=; apply Eq_trans.
  - do 2 case=> ? //=; apply Eq_inv.
Qed.

Instance EqExact_Down {a} `{EqExact a} : EqExact (Down a).
Proof.
  split;
  unfold op_zeze__, op_zsze__;
  unfold Ord.Eq___Down;
  unfold op_zeze____, op_zsze____;
  unfold Ord.Eq___Down_op_zsze__;
  unfold Ord.Eq___Down_op_zeze__;
  unfold coerce, Coercible_Unpeel, unpeel, repeel, Unpeel_refl;
  unfold Unpeel_arrow, Unpeel_Down, unpeel, repeel.
  unfold Eq___Down
     => - [x] [y] /=.
  case E: (x == y); constructor; move/Eq_eq in E.
  + by rewrite E.
  + by contradict E; case: E.
Qed.


Add LoadPath "C:\td202\GitHub\coq\views".

Require Import Heaps.
Require Import String.
Require Import FractionalPermissions.
Require Import MSets.
Require Import SetoidClass.
Require Import Tactics.
Require Import CountableFiniteMaps.
Require Import SeparationAlgebras.
Require Import Setof.
Require Import HeapSeparationAlgebra.
Require Import SeparationAlgebraProduct.

Module CAPModel (ht : HeapTypes) .
 Module Export TheHeap := MHeaps ht.
 Module HSA := (HeapSA ht TheHeap).

 (* Action identifiers are pairs of string and lists of values *)
 Definition AID := (string * (list Val))%type.

 (* Region identifiers are natural numbers. *)
 Definition RID := nat.
 Program Instance RID_Setoid : Setoid RID.
 Program Instance RID_Countable : Countable RID.
 Solve Obligations using firstorder.

 (* Tokens are pairs of region idenitifer and
    action identifier. *)
 Record Token := { tok_rid : RID; tok_aid : AID }.

 Module CapPSAP <: PermissionSeparationAlgebraParams.
   Definition A := Token.
   Definition PA := FracPerm.T.
   Instance PA_Setoid : Setoid PA := FracPerm.FPsetoid.
   Definition op : partial_dec_op PA := FracPerm.plus.
   Instance PA_PermAlg : PermAlgMixin op := FracPerm.FP_pa.
 End CapPSAP.

 Module CapSA := PermissionSeparationAlgebra CapPSAP.

 Definition Cap := CapSA.S.

 Definition LState := (store * Cap)%type.

 Existing Instance prod_setoid.
 Existing Instance prod_SA.
 Definition ls_sepop := prod_sepop _ HSA.sepop _ CapSA.sepop.
 Instance ls_SA : SepAlg ls_sepop := prod_SA _ _ _ _.

 Definition SState := CFMap RID LState.

 Definition lcol (l : LState) (s : SState) : partial_val (T:=LState)
  :=
   cfm_dom_fold
  (fun (X : partial_val) (a : RID) (H : cfm_def_at s a) =>
   lift_op ls_sepop X (lift_val (cfm_def_get H))) (lift_val l).

 Definition Act := SState -> LState -> Prop.
 Definition AMod := Token -> option Act.

 Record wellformed (l : LState) (s : SState) (a : AMod) : Prop :=
   {
     wf_col_def : defined (lcol l s);
     wf_caps_acts : forall t, None = a t -> (snd (val (lcol l s))) t == FracPerm.zero;
     wf_act_regs : forall t, None = cfm s (tok_rid t) -> None = a t
   }.

 Record world :=
   {
     wrld_local : LState;
     wrld_shared : SState;
     wrld_amod : AMod;
     wrld_wf :> wellformed wrld_local wrld_shared wrld_amod
   }.

 Existing Instance cfm_setoid.
 Definition world_sepop : partial_op world.
  intros w1 w2.
  destruct w1.
  destruct w2.
  set (ls_sepop wrld_local0 wrld_local1).
  set (defined p /\ wrld_shared0 == wrld_shared1 /\ wrld_amod0 == wrld_amod1).
  split.
  exact (defined p /\ wrld_shared0 == wrld_shared1 /\ wrld_amod0 == wrld_amod1).

  remember (ls_sepop wrld_local0 wrld_local1).
  destruct p.

  split.

 HSA.sepop

End CAPModel.


Require Export Nat.
Require Export ch2o.prelude.orders.
Require Export ch2o.prelude.nmap.
Require Export ch2o.prelude.stringmap.
Require Export ch2o.memory.memory_basics.
Require Export ch2o.abstract_c.architectures.
Require Export ch2o.abstract_c.interpreter.
Require Export ch2o.abstract_c.frontend_sound.
Require Export ch2o.core_c.smallstep.
Require Export ch2o.core_c.restricted_smallstep.
Require Export ch2o.core_c.expression_eval_smallstep.
Require Export core_c_trivial_bigstep.
Require Export three_locals.

Definition get_right{A B}(v: A + B)(H: match v with inl _ => False | inr _ => True end): B.
destruct v.
elim H.
exact b.
Defined.

Open Local Scope string_scope.

Definition A: architecture := {|
  arch_sizes := architectures.lp64;
  arch_big_endian := false;
  arch_char_signedness := Signed;
  arch_alloc_can_fail := false
|}.
Notation K := (arch_rank A).

Notation M := (error (frontend_state K) string).

Lemma alloc_program_ok: match alloc_program (K:=K) decls empty with inl _ => False | inr _ => True end.
exact I.
Qed.

Definition alloc_program_result: frontend_state K.
eapply snd.
eapply get_right.
apply alloc_program_ok.
Defined.

Compute (stringmap_to_list (env_t (to_env alloc_program_result))).
Compute (stringmap_to_list (env_f (to_env alloc_program_result))).

Definition to_core_c_program: M (env K * funenv K * state K) :=
  _ ← alloc_program decls;
  Δg ← gets to_globals;
  '(_,σs,σ,_) ← error_of_option (Δg !! "main"≫= maybe4 Fun)
    ("function `main` undeclared`");
  guard (σ = sintT%T ∨ σ = uintT%T) with
    ("function `main` should have return type `int`");
  Γ ← gets to_env;
  δ ← gets to_funenv;
  m ← gets to_mem;
  mret (Γ, δ, initial_state m "main" []).

Definition to_core_c_program_result: string + env K * funenv K * state K :=
  error_eval to_core_c_program ∅.

Lemma to_core_c_program_ok: match to_core_c_program_result with inl _ => False | inr _ => True end.
exact I.
Qed.

Definition core_c_program: env K * funenv K * state K := get_right to_core_c_program_result to_core_c_program_ok.

Definition Γ: env K := to_env alloc_program_result.
Definition δ: funenv K := to_funenv alloc_program_result.
Definition m0: mem K := to_mem alloc_program_result.
Definition S0 := initial_state m0 "main" [].

Lemma alloc_program_eq: alloc_program decls empty = mret () alloc_program_result.
reflexivity.
Qed.

Lemma Γ_valid: ✓ Γ.
apply alloc_program_valid with (1:=alloc_program_eq).
Qed.

Lemma δ_valid: ✓{Γ,'{m0}} δ.
apply alloc_program_valid with (1:=alloc_program_eq).
Qed.

Lemma m0_valid: ✓{Γ} m0.
apply alloc_program_valid with (1:=alloc_program_eq).
Qed.

Goal forall S, rtc (cstep Γ δ) S0 S -> ~ is_undef_state S.
intros.
intro HS.
apply csteps_rcsteps in H.
inv_rcsteps H. elim (is_Some_None HS).
inversion H; clear H; subst.
destruct os; try discriminate.
clear H7 H8.
assert (match Some s with None => s | Some s => s end = s). {
  reflexivity.
}
rewrite <- H6 in H.
simpl in H.
subst.
clear H6.
assert (m0 = ∅). reflexivity.
rewrite H in H1. clear H.
simpl in H1.
apply exec_sound with (z:=2) in H1. {
  destruct H1 as [m H1].
  inv_rcsteps H1. elim (is_Some_None HS).
  inv_rcstep.
  inv_rcsteps H1. elim (is_Some_None HS).
  inv_rcstep.
}
apply Γ_valid.
Focus 2. {
  destruct S as [k [] m]; try (elim (is_Some_None HS)); exact I.
} Unfocus.
clear HS H1 S.

econstructor.
econstructor.
- econstructor.
  + simpl; lia.
  + econstructor.
  + split.
    * unfold int_lower.
      simpl.
      lia.
    * unfold int_upper.
      simpl.
      lia.
- econstructor.
  econstructor.
  + econstructor.
    * simpl; lia.
    * econstructor.
    * split; try unfold int_lower; try unfold int_upper; simpl; lia.
  + econstructor.
    econstructor.
    * econstructor.
      -- simpl; lia.
      -- econstructor.
         reflexivity.
      -- split; try unfold int_lower; try unfold int_upper; simpl; lia.
    * econstructor.
      -- econstructor.
         reflexivity.
      -- split; try unfold int_lower; try unfold int_upper; simpl; lia.
Qed.