Require Import FJ_tactics.
Require Import List.
Require Import Functors.
Require Import FunctionalExtensionality.
Require Import MonadLib.
Require Import Names.
Require Import EffPure.

Section Bool.

  (* ============================================== *)
  (* TYPES                                          *)
  (* ============================================== *)

  (* The Boolean Type. *)
  Inductive BType (A : Set) : Set :=
  | TBool : BType A.

  Definition BType_fmap : forall (A B : Set) (f : A -> B),
    BType A -> BType B := fun A B _ _ => TBool _.

  Global Instance BType_Functor : Functor BType :=
    {| fmap := BType_fmap |}.
    destruct a; reflexivity.
    (* fmap id *)
    destruct a; reflexivity.
  Defined.

  Variable D : Set -> Set.
  Context {Fun_D : Functor D}.
  Definition DType := DType D.
  Context {Sub_BType_D  : BType :<: D}.

   (* Constructor + Universal Property. *)
  Context {WF_Sub_BType_D : WF_Functor _ _ Sub_BType_D _ _}.

  Definition tbool' : DType := inject' (TBool _).
  Definition tbool : Fix D := proj1_sig tbool'.
  Global Instance UP'_tbool :
    Universal_Property'_fold tbool := proj2_sig tbool'.

  (* Induction Principle for Nat Types. *)
  Definition ind_alg_BType
    (P : forall d : Fix D, Universal_Property'_fold d -> Prop)
    (H : UP'_P P tbool)
    (d : BType (sig (UP'_P P))) : sig (UP'_P P) :=
    match d with
      | TBot => exist _ _ H
    end.

    Lemma WF_ind_alg_BType {Sub_BType_D' : BType :<: D}
    (eq_Sub_BType : forall A (d : BType A),
      inj (Sub_Functor := Sub_BType_D) d = inj (Sub_Functor := Sub_BType_D') d)
    (Name : Set)
    (P : forall e : Fix D, Universal_Property'_fold e -> Prop)
    (H : UP'_P P tbool)
    : PAlgebra Name BType D (sub_F_G := Sub_BType_D') (UP'_P P).
      econstructor 1 with (p_algebra := ind_alg_BType P H).
      intros; destruct e; simpl;
      unfold tbool, tbool'; simpl; rewrite wf_functor; simpl; apply f_equal; eauto.
    Defined.

  (* Type Equality Section. *)
  Definition isTBool : Fix D -> bool :=
   fun typ =>
     match project typ with
      | Some TBool => true
      | None      => false
     end.

  Definition BType_eq_DType  (R : Set) (rec : R -> eq_DTypeR D)
    (e : BType R) : eq_DTypeR D :=
    match e with
      | TBool => fun t => isTBool (proj1_sig t)
    end.

  Global Instance MAlgebra_eq_DType_Bool T:
    FAlgebra eq_DTypeName T (eq_DTypeR D) BType :=
    {| f_algebra := BType_eq_DType T|}.

  Context {eq_DType_DT : forall T, FAlgebra eq_DTypeName T (eq_DTypeR D) D}.
  Context {WF_DType_eq_DT : forall T, @WF_FAlgebra eq_DTypeName T _ _ _
    Sub_BType_D (MAlgebra_eq_DType_Bool T) (eq_DType_DT _)}.

  Global Instance PAlgebra_eq_DType_neq_BType {Sub_BType_D' : BType :<: D}
    (eq_Sub_BType : forall A (d : BType A),
      inj (Sub_Functor := Sub_BType_D) d = inj (Sub_Functor := Sub_BType_D') d):
    PAlgebra eq_DType_neqName BType D (sub_F_G := Sub_BType_D') (UP'_P (eq_DType_neq_P D)).
  Proof.
    apply WF_ind_alg_BType; eauto.
    unfold UP'_P; econstructor.
    unfold eq_DType_neq_P; intros.
    unfold eq_DType, mfold, tbool, tbool', inject' in H; simpl in H;
      repeat rewrite wf_functor in H; simpl in H; unfold in_t in H.
    rewrite (wf_algebra (WF_FAlgebra := WF_DType_eq_DT _)) in H; simpl in H.
    unfold not; intros; rewrite <- H0 in H.
    unfold isTBool, project, tbool, inject in H; simpl in H.
    rewrite out_in_fmap in H; repeat rewrite wf_functor in H;
      simpl in H; rewrite prj_inj in H; discriminate.
  Qed.

  Global Instance PAlgebra_eq_DType_eq_BType {Sub_BType_D' : BType :<: D}
    (eq_Sub_BType : forall A (d : BType A),
      inj (Sub_Functor := Sub_BType_D) d = inj (Sub_Functor := Sub_BType_D') d):
    PAlgebra eq_DType_eqName BType D (sub_F_G := Sub_BType_D') (UP'_P (eq_DType_eq_P D)).
  Proof.
    apply WF_ind_alg_BType; eauto.
    unfold UP'_P; econstructor.
    unfold eq_DType_eq_P; intros.
    unfold eq_DType, mfold, tbool, tbool', inject' in H; simpl in H;
      repeat rewrite wf_functor in H; simpl in H; unfold in_t in H.
    rewrite (wf_algebra (WF_FAlgebra := WF_DType_eq_DT _)) in H; simpl in H.
    unfold isTBool in H.
    caseEq (project (subGF := Sub_BType_D) (proj1_sig d2)); rewrite H0 in H;
      try discriminate; destruct b.
    unfold project in H0.
    apply inj_prj in H0.
    unfold tbool, tbool'; simpl; rewrite wf_functor; simpl.
    unfold BType_fmap.
    generalize (f_equal (in_t_UP' _ _ ) H0); intros.
    apply (f_equal (@proj1_sig _ _)) in H1;
      rewrite in_out_UP'_inverse in H1.
    rewrite H1; simpl; rewrite wf_functor; simpl; unfold BType_fmap;
      reflexivity.
    exact (proj2_sig d2).
  Defined.

  (* ============================================== *)
  (* EXPRESSIONS                                    *)
  (* ============================================== *)

  Inductive Bool (a : Set) : Set :=
  | BLit : bool -> Bool a
  | If : a -> a -> a -> Bool a.

  Definition Bool_fmap (B C : Set) (f : B -> C) (Aa : Bool B) : Bool C :=
    match Aa with
      | BLit n => BLit _ n
      | If i t e => If _ (f i) (f t) (f e)
    end.

  Global Instance Bool_Functor : Functor Bool :=
    {| fmap := Bool_fmap |}.
    destruct a; reflexivity.
    (* fmap id *)
    destruct a; reflexivity.
  Defined.

  Variable F : Set -> Set.
  Context {Fun_F : Functor F}.
  Definition Exp := Exp F.
  Context {Sub_Bool_F : Bool :<: F}.

  (* Constructor + Universal Property. *)
   Context {WF_Sub_Bool_F : WF_Functor _ _ Sub_Bool_F _ _}.
  Definition blit' (b : bool) : Exp :=
    inject' (BLit _ b).
  Definition blit (b : bool) : Fix F := proj1_sig (blit' b).
  Global Instance UP'_blit {b : bool} :
    Universal_Property'_fold (blit b) := proj2_sig (blit' b).

  Definition cond' (i t e : Exp) : Exp :=
    inject' (If _ i t e).

  Definition cond (i t e : Fix F)
    {UP'_i : Universal_Property'_fold i}
    {UP'_t : Universal_Property'_fold t}
    {UP'_e : Universal_Property'_fold e}
    : Fix F := proj1_sig (cond' (exist _ _ UP'_i) (exist _ _ UP'_t) (exist _ _ UP'_e)).

  Global Instance UP'_cond  {i t e : Fix F }
    {UP'_i : Universal_Property'_fold i}
    {UP'_t : Universal_Property'_fold t}
    {UP'_e : Universal_Property'_fold e}
    :
    Universal_Property'_fold (cond i t e) :=
    proj2_sig (cond' (exist _ _ UP'_i) (exist _ _ UP'_t) (exist _ _ UP'_e)).

  (* Induction Principle for Bool. *)
  Definition ind_alg_Bool
    (P : forall e : Fix (F), Universal_Property'_fold e -> Prop)
    (H : forall b, UP'_P P (blit b))
    (H0 : forall i t e
      (IHi : UP'_P P i)
      (IHt : UP'_P P t)
      (IHe : UP'_P P e),
      UP'_P P (@cond i t e (proj1_sig IHi) (proj1_sig IHt) (proj1_sig IHe)))
    (e : Bool (sig (UP'_P P)))
    :
    sig (UP'_P P) :=
    match e with
      | BLit n => exist _ (blit n) (H n)
      | If i t e => exist (UP'_P P) _
        (H0 (proj1_sig i) (proj1_sig t) (proj1_sig e) (proj2_sig i) (proj2_sig t) (proj2_sig e))
    end.

  Definition ind2_alg_Bool
    {E E' : Set -> Set}
    {Fun_E : Functor E}
    {Fun_E' : Functor E'}
    {Sub_Bool_E : Bool :<: E}
    {Sub_Bool_E' : Bool :<: E'}
    (P : forall e : (Fix E) * (Fix E'),
      Universal_Property'_fold (fst e) /\ Universal_Property'_fold (snd e) -> Prop)
    (H : forall b, UP'_P2 P (inject (BLit _ b), inject (BLit _ b)))
    (H0 : forall i t el
      (IHi : UP'_P2 P i)
      (IHt : UP'_P2 P t)
      (IHel : UP'_P2 P el),
      UP'_P2 P (inject (If _ (exist _ _ (proj1 (proj1_sig IHi)))
        (exist _ _ (proj1 (proj1_sig IHt))) (exist _ _(proj1 (proj1_sig IHel)))),
      inject (If _ (exist _ _ (proj2 (proj1_sig IHi)))
        (exist _ _ (proj2 (proj1_sig IHt))) (exist _ _ (proj2 (proj1_sig IHel))))))
      (e : Bool (sig (UP'_P2 P)))
        :
        sig (UP'_P2 P) :=
    match e with
      | BLit b => exist _ _ (H b)
      | If i t e => exist (UP'_P2 P) _
        (H0 (proj1_sig i) (proj1_sig t) (proj1_sig e)
          (proj2_sig i) (proj2_sig t) (proj2_sig e))
    end.

  Lemma ind_PAlg_Bool {Sub_Bool_F' : Bool :<: F}
    (eq_Sub_Bool : forall A (d : Bool A),
      inj (Sub_Functor := Sub_Bool_F) d = inj (Sub_Functor := Sub_Bool_F') d)
    (Name : Set)
    (P : forall e : Fix F, Universal_Property'_fold e -> Prop)
    (H : forall b, UP'_P P (blit b))
    (H0 : forall i t e
      (IHi : UP'_P P i)
      (IHt : UP'_P P t)
      (IHe : UP'_P P e),
      UP'_P P (@cond i t e (proj1_sig IHi) (proj1_sig IHt) (proj1_sig IHe)))
    :
    PAlgebra Name Bool F (sub_F_G := Sub_Bool_F') (UP'_P P).
    econstructor 1 with (p_algebra := ind_alg_Bool P H H0).
    destruct e; simpl.
    unfold blit, blit'; simpl; rewrite wf_functor; rewrite eq_Sub_Bool; reflexivity.
    unfold cond, cond'; simpl; rewrite wf_functor; rewrite eq_Sub_Bool; reflexivity.
  Qed.

  Lemma ind_P2Alg_Bool (Name : Set)
    (E E' : Set -> Set)
    {Fun_E : Functor E}
    {Fun_E' : Functor E'}
    {Sub_Bool_E : Bool :<: E}
    {Sub_Bool_E' : Bool :<: E'}
    {WF_Fun_E : WF_Functor _ _ _ _ Fun_E}
    {WF_Fun_E' : WF_Functor _ _ _ _ Fun_E'}
    (P : forall e : (Fix E) * (Fix E'),
      Universal_Property'_fold (fst e) /\ Universal_Property'_fold (snd e) -> Prop)
    (H : forall b, UP'_P2 P (inject (BLit _ b), inject (BLit _ b)))
    (H0 : forall i t el
      (IHi : UP'_P2 P i)
      (IHt : UP'_P2 P t)
      (IHel : UP'_P2 P el),
      UP'_P2 P (inject (If _ (exist _ _ (proj1 (proj1_sig IHi)))
        (exist _ _ (proj1 (proj1_sig IHt))) (exist _ _(proj1 (proj1_sig IHel)))),
      inject (If _ (exist _ _ (proj2 (proj1_sig IHi)))
        (exist _ _ (proj2 (proj1_sig IHt))) (exist _ _ (proj2 (proj1_sig IHel))))))
    :
    P2Algebra Name Bool E E' (UP'_P2 P).
    econstructor 1 with (p2_algebra := ind2_alg_Bool P H H0);
    destruct e; simpl; unfold inject; simpl; rewrite wf_functor; reflexivity.
  Qed.

  Definition ind_dalg_Bool
    (P : forall e : Fix (F), Universal_Property'_fold e -> Set)
    (H : forall b, UP'_SP P (blit b))
    (H0 : forall i t e
      (IHi : UP'_SP P i)
      (IHt : UP'_SP P t)
      (IHe : UP'_SP P e),
      UP'_SP P (@cond i t e (projT1 IHi) (projT1 IHt) (projT1 IHe)))
    (e : Bool (sigT (UP'_SP P)))
    :
    sigT (UP'_SP P) :=
    match e with
      | BLit n => existT _ (blit n) (H n)
      | If i t e => existT (UP'_SP P) _
        (H0 (projT1 i) (projT1 t) (projT1 e) (projT2 i) (projT2 t) (projT2 e))
    end.

  Lemma ind_DAlg_Bool
    (Name : Set)
    (P : forall e : Fix F, Universal_Property'_fold e -> Set)
    (H : forall b, UP'_SP P (blit b))
    (H0 : forall i t e
      (IHi : UP'_SP P i)
      (IHt : UP'_SP P t)
      (IHe : UP'_SP P e),
      UP'_SP P (@cond i t e (projT1 IHi) (projT1 IHt) (projT1 IHe)))
    :
    DAlgebra Name Bool F (UP'_SP P).
    econstructor 1 with (d_algebra := ind_dalg_Bool P H H0).
    destruct e; simpl.
    unfold blit, blit'; simpl; rewrite wf_functor; reflexivity.
    unfold cond, cond'; simpl; rewrite wf_functor; reflexivity.
  Qed.

  (* ============================================== *)
  (* TYPING                                         *)
  (* ============================================== *)

  (* Typing Boolean Expressions. *)

  Variable (MT : Set -> Set). (* The Typing Monad *)
  Context {Fun_MT : Functor MT}.
  Context {Mon_MT : Monad MT}.
  Context {Fail_MT : FailMonad MT}.
  Context {MT_eq_dec : forall (A : Set) (mta : MT A),
    {exists a, mta = return_ a} + {mta = fail}}.

  Definition Bool_typeof (R : Set) (rec : R -> typeofR D MT)
     (e : Bool R) : typeofR D MT :=
     match e with
       | BLit n => return_ tbool'
       | If i t e => do Ti <- rec i;
                     match isTBool (proj1_sig Ti) with
                       | true => do Tt <- rec t;
                                 do Te <- rec e;
                                   match eq_DType D (proj1_sig Tt) Te with
                                     | true => return_ Tt
                                     | _ => fail
                                   end
                       | _ => fail
                     end
     end.

  Global Instance MAlgebra_typeof_Bool T :
    FAlgebra TypeofName T (typeofR D MT ) Bool :=
    {| f_algebra := Bool_typeof T|}.

  (* ============================================== *)
  (* VALUES                                         *)
  (* ============================================== *)

  (* Boolmetic Values. *)
   Inductive BoolValue (A : Set) : Set :=
   | VB : bool -> BoolValue A.

   Definition VB_fmap : forall (A B : Set) (f : A -> B),
     BoolValue A -> BoolValue B :=
     fun A B _ e => match e with
                      | VB n => VB _ n
                    end.

   Global Instance VB_Functor : Functor BoolValue :=
     {| fmap := VB_fmap |}.
     destruct a; reflexivity.
     destruct a; reflexivity.
   Defined.

   Variable V : Set -> Set.
   Context {Fun_V : Functor V}.
   Definition Value := Value V.
   Context {Sub_BoolValue_V : BoolValue :<: V}.

  (* Constructor + Universal Property. *)
  Context {WF_Sub_BoolValue_F : WF_Functor _ _ Sub_BoolValue_V _ _}.

  Definition vb' (b : bool) : Value := inject' (VB _ b).
  Definition vb (b : bool) : Fix V := proj1_sig (vb' b).

  Global Instance UP'_vb {b : bool} :
    Universal_Property'_fold (vb b) := proj2_sig (vb' b).

  (* Constructor Testing for Boolmetic Values. *)

  Definition isVB : Fix V -> option bool :=
    fun exp =>
      match project exp with
       | Some (VB b) => Some b
       | None        => None
      end.

   Lemma project_vb_vb : forall b,
     project (F := V) (G := BoolValue) (vb b) = Some (VB _ b).
   Proof.
     intros; unfold project, vb, inject; simpl; rewrite out_in_fmap.
     repeat rewrite wf_functor; simpl; unfold VB_fmap.
     rewrite prj_inj; reflexivity.
   Qed.

   Lemma project_vb'_vb : forall b,
     project (F := V) (G := BoolValue) (proj1_sig (vb' b)) = Some (VB _ b).
   Proof.
     intros; unfold project, vb', inject; simpl; rewrite out_in_fmap.
     repeat rewrite wf_functor; simpl; unfold VB_fmap.
     rewrite prj_inj; reflexivity.
   Qed.

  Context {Sub_StuckValue_V : StuckValue :<: V}.
  Definition stuck' : nat -> Value := stuck' _.
  Definition stuck : nat -> Fix V := stuck _.

  (* ============================================== *)
  (* EVALUATION                                     *)
  (* ============================================== *)

  Context {Sub_BotValue_V : BotValue :<: V}.

  (* Evaluation Algebra for Boolemetic Expressions. *)

  Definition Bool_eval (R : Set) (rec : R -> evalR V)
    (e : Bool R) : evalR V :=
      match e with
        | BLit b => (fun _ => vb' b)
        | If i t e => (fun env =>
          let i' := (rec i env) in
            match (isVB (proj1_sig i')) with
              | Some true => rec t env
              | Some false => rec e env
              | None => if (@isBot _ Fun_V Sub_BotValue_V (proj1_sig i'))
                         then bot' V
                         else stuck' 5
            end)
      end.

  Global Instance MAlgebra_eval_Bool T :
    FAlgebra EvalName T (evalR V) Bool :=
    {| f_algebra := Bool_eval T |}.

  Variable (ME : Set -> Set). (* Evaluation Monad. *)
  Context {Fun_M : Functor ME}.
  Context {Mon_M : Monad ME}.
  Context {Fail_M : FailMonad ME}.

  Definition Bool_evalM (R : Set) (rec : R -> evalMR V ME)
     (e : Bool R) : evalMR V ME :=
       match e with
         | BLit b => return_ (vb' b)
         | If i t e => do i' <- rec i;
                         match (isVB (proj1_sig i')) with
                           | Some true => rec t
                           | Some false => rec e
                           | _ => return_ (stuck' 5)
                         end
       end.

  Global Instance MAlgebra_evalM_Bool T :
    FAlgebra EvalName T (evalMR V ME) Bool :=
    {| f_algebra := Bool_evalM T |}.

  (* ============================================== *)
  (* PRETTY PRINTING                                *)
  (* ============================================== *)

  (* Pretty Printing Functions*)

  Require Import Ascii.
  Require Import String.

  Global Instance MAlgebra_DTypePrint_BType T:
    FAlgebra DTypePrintName T DTypePrintR BType :=
    {| f_algebra := fun rec e => append "tbool" "" |}.

  Global Instance MAlgebra_ExpPrint_Bool T :
    FAlgebra ExpPrintName T (ExpPrintR) Bool :=
    {| f_algebra := fun rec e =>
      match e with
        | BLit true => fun i => append "true" ""
        | BLit false => fun i => append "false" ""
        | If i t e => fun i' => append "(if (" ((rec i i') ++ ") then (" ++ (rec t i') ++ ") else ("++ (rec e i')++"))")
    end |}.

  Global Instance MAlgebra_ValuePrint_BType T :
    FAlgebra ValuePrintName T ValuePrintR BoolValue :=
    {| f_algebra := fun rec e =>
      match e with
        | VB true => append "true" ""
        | VB false => append "false" ""
      end |}.

  Context {eval_F : FAlgebra EvalName Exp (evalR V) F}.
  Context {WF_eval_F : @WF_FAlgebra EvalName _ _ (Bool) (F)
    (Sub_Bool_F) (MAlgebra_eval_Bool (Exp)) eval_F}.

  Context {WF_SubBotValue_V : WF_Functor BotValue V Sub_BotValue_V Bot_Functor Fun_V}.
  Context {Dis_VB_Bot : Distinct_Sub_Functor _ Sub_BoolValue_V Sub_BotValue_V}.

  (* ============================================== *)
  (* WELL-FORMED BOOLEAN VALUES                     *)
  (* ============================================== *)

  Variable TypContext : Set.

  Variable WFV : (WFValue_i D V TypContext -> Prop) -> WFValue_i D V TypContext -> Prop.
  Variable funWFV : iFunctor WFV.

  (** Natural Number Values are well-formed **)

  Inductive WFValue_VB (WFV : WFValue_i D V TypContext -> Prop) : WFValue_i D V TypContext -> Prop :=
  | WFV_VB : forall Sigma n (v : Names.Value V) T,
    proj1_sig v = vb n ->
    proj1_sig T = tbool ->
    WFValue_VB WFV (mk_WFValue_i D V _ Sigma v T).

  Definition ind_alg_WFV_VB (P : WFValue_i D V TypContext -> Prop)
    (H : forall Sigma n v T veq Teq, P (mk_WFValue_i _ _ _ Sigma v T))
    i (e : WFValue_VB P i) : P i :=
    match e in WFValue_VB _ i return P i with
      | WFV_VB Sigma n v T veq Teq => H Sigma n v T veq Teq
    end.

  Definition WFV_VB_ifmap (A B : WFValue_i D V _ -> Prop) i (f : forall i, A i -> B i)
    (WFV_a : WFValue_VB A i) : WFValue_VB B i :=
    match WFV_a in (WFValue_VB _ s) return (WFValue_VB B s)
      with
      | WFV_VB Sigma n v T veq Teq => WFV_VB B Sigma n v T veq Teq
    end.

  Global Instance iFun_WFV_VB : iFunctor WFValue_VB.
    constructor 1 with (ifmap := WFV_VB_ifmap).
    destruct a; simpl; intros; reflexivity.
    destruct a; simpl; intros; reflexivity.
  Defined.

  Variable Sub_WFV_VB_WFV : Sub_iFunctor WFValue_VB WFV.

   Global Instance WFV_proj1_a_VB :
     iPAlgebra WFV_proj1_a_Name (WFV_proj1_a_P D V _ WFV) WFValue_VB.
     econstructor; intros.
     unfold iAlgebra; intros; unfold WFV_proj1_a_P.
     inversion H; subst; simpl; intros.
     apply (inject_i (subGF := Sub_WFV_VB_WFV)); econstructor; simpl; eauto.
     rewrite H3; eauto.
   Defined.

   Global Instance WFV_proj1_b_VB :
     iPAlgebra WFV_proj1_b_Name (WFV_proj1_b_P D V _ WFV) WFValue_VB.
     econstructor; intros.
     unfold iAlgebra; intros; unfold WFV_proj1_b_P.
     inversion H; subst; simpl; intros.
     apply (inject_i (subGF := Sub_WFV_VB_WFV)); econstructor; simpl; eauto.
     rewrite H3; eauto.
   Defined.

  (* Inversion principles for Well-formed Booleans. *)
  Definition WF_invertVB_P (i : WFValue_i D V _) :=
    proj1_sig (wfv_T _ _ _ i) = tbool -> WFValue_VB (iFix WFV) i.

  Inductive WF_invertVB_Name := wfv_invertvb_name.
  Context {WF_invertVB_WFV :
    iPAlgebra WF_invertVB_Name WF_invertVB_P WFV}.

  Global Instance WF_invertVB_VB :
    iPAlgebra WF_invertVB_Name WF_invertVB_P WFValue_VB.
    econstructor; intros.
    unfold iAlgebra; intros; unfold WF_invertVB_P.
    inversion H; subst; simpl; intros.
    econstructor; eassumption.
  Defined.

  Ltac WF_invertVB_default :=
    constructor; unfold iAlgebra; intros i H; unfold WF_invertVB_P;
      inversion H; simpl;
        match goal with
          eq_H0 : proj1_sig ?T = _ |- proj1_sig ?T = _ -> _ =>
            intro eq_H; rewrite eq_H in eq_H0;
              elimtype False; eapply (inject_discriminate _ _ _ eq_H0)
        end.

  Definition WF_invertVB := ifold_ WFV _ (ip_algebra (iPAlgebra := WF_invertVB_WFV)).

  Context {TypContextCE : ConsExtensionC TypContext}.

  Global Instance WFV_Weaken_VB :
    iPAlgebra WFValue_Weaken_Name (WFValue_Weaken_P D V _ WFV) WFValue_VB.
  Proof.
    econstructor; intros.
    unfold iAlgebra; intros; unfold WFValue_Weaken_P.
    inversion H; subst; simpl; intros.
    apply inject_i; econstructor; eassumption.
  Defined.

  (* ============================================== *)
  (* TYPE SOUNDNESS                                 *)
  (* ============================================== *)

    Context {WFV_proj1_a_WFV :
      iPAlgebra WFV_proj1_a_Name (WFV_proj1_a_P D V _ WFV) WFV}.
    Context {WFV_proj1_b_WFV :
       iPAlgebra WFV_proj1_b_Name (WFV_proj1_b_P D V _ WFV) WFV}.
    Context {eq_DType_eq_DT : PAlgebra eq_DType_eqName D D (UP'_P (eq_DType_eq_P D))}.
    Context {eq_DType_neq_DT : PAlgebra eq_DType_neqName D D (UP'_P (eq_DType_neq_P D))}.

    Variable WFVM : (WFValueM_i D V MT ME TypContext -> Prop) -> WFValueM_i D V MT ME TypContext -> Prop.
    Context {funWFVM : iFunctor WFVM}.

    Context {Typeof_F : forall T, FAlgebra TypeofName T (typeofR D MT) F}.
    Context {WF_Typeof_F : forall T, @WF_FAlgebra TypeofName _ _ Bool F
      Sub_Bool_F (MAlgebra_typeof_Bool _) (Typeof_F T)}.

    Context {evalM_F' : forall T, FAlgebra EvalName T (evalMR V ME) F}.
    Context {WF_evalM_F' : forall T, @WF_FAlgebra EvalName _ _ Bool F
      Sub_Bool_F (MAlgebra_evalM_Bool _) (evalM_F' T)}.

    Context {Sub_WFVM_base_WFVM : Sub_iFunctor (WFValueM_base D V MT ME _ WFV) WFVM}.

    Ltac WF_FAlg_rewrite := repeat rewrite wf_functor; simpl;
      repeat rewrite out_in_fmap; simpl;
        repeat rewrite wf_functor; simpl;
          repeat rewrite wf_algebra; simpl.

    Lemma Bool_eval_Soundness_H : forall b : bool,
      UP'_SP (eval_soundness_P D V F MT ME _ WFVM) (blit b).
    Proof.
      intros; econstructor.
      unfold eval_soundness_P; intros; simpl.
      unfold typeof, evalM, mfold, blit; simpl; unfold in_t; simpl.
      WF_FAlg_rewrite.
      apply (inject_i (subGF := Sub_WFVM_base_WFVM)); econstructor 1 with (T := tbool').
      apply inject_i; econstructor; unfold vb; simpl; auto.
      apply return_orn; auto.
    Defined.

    Lemma project_tbool_tbool : project (F := D) (G := BType) tbool = Some (TBool _).
    Proof.
      intros; unfold project, tbool, inject; simpl; rewrite out_in_fmap.
      repeat rewrite wf_functor; simpl; rewrite prj_inj; reflexivity.
    Qed.

    Lemma project_tbool'_tbool : project (F := D) (G := BType) (proj1_sig tbool') = Some (TBool _).
    Proof.
      intros; unfold project, tbool', inject; simpl; rewrite out_in_fmap.
      repeat rewrite wf_functor; simpl; rewrite prj_inj; reflexivity.
    Qed.

    Context {wfvm_bind_alg :
      iPAlgebra wfvm_bind_Name (wfvm_bind_P D V MT ME _ WFV WFVM (TypContextCE := TypContextCE)) WFVM}.

    Lemma Bool_eval_soundness'_H0
     (typeof_R eval_R : Set) typeof_rec eval_rec :
     forall (iT tT eT : typeof_R) (iE tE eE : eval_R)
       Sigma
       (IHi :  WFValueMC D V MT ME _ WFVM Sigma
         (eval_rec iE) (typeof_rec iT))
       (IHt : forall Sigma', ConsExtension Sigma' Sigma ->
         WFValueMC D V MT ME _ WFVM Sigma'
         (eval_rec tE) (typeof_rec tT))
       (IHe : forall Sigma', ConsExtension Sigma' Sigma ->
         WFValueMC D V MT ME _ WFVM Sigma'
         (eval_rec eE) (typeof_rec eT)),
       WFValueMC D V MT ME _ WFVM Sigma
         (Bool_evalM _ eval_rec (If _ iE tE eE))
         (Bool_typeof _ typeof_rec (If _ iT tT eT)).
    Proof.
      simpl; intros.
      apply wfvm_bind with (WFV := WFV) (TypContextCE := TypContextCE); auto.
      intros; rewrite H; reflexivity.
      intros.
      caseEq (project (proj1_sig T)); rename H1 into T_eq.
      destruct b.
      apply project_inject in T_eq; auto with typeclass_instances; try exact (proj2_sig _).
      generalize (WF_invertVB _ H0 T_eq) as WF_v_T; intros;
        inversion WF_v_T; subst; rewrite H5.
      unfold isTBool; rewrite project_tbool_tbool.
      unfold isVB; rewrite H3, project_vb_vb.
      destruct n.
      rewrite right_unit at 1.
      apply wfvm_bind with (WFV := WFV) (TypContextCE := TypContextCE); auto.
      intros; unfold eq_DType; rewrite H1.
      repeat rewrite fmap_m.
      repeat rewrite <- associativity.
      f_equal; apply functional_extensionality; intro Te.
      destruct (mfold (eq_DTypeR D) (fun R : Set => f_algebra) (proj1_sig T') Te).
      repeat rewrite <- left_unit; rewrite H1; reflexivity.
      repeat rewrite bind_fail; reflexivity.
      intros.
      apply wfvm_skip with (WFV := WFV) (Fail_MT := Fail_MT) (Monad_ME := Mon_M); auto.
      intro Te.
      caseEq (eq_DType D (proj1_sig T0) Te).
      apply (inject_i (subGF := Sub_WFVM_base_WFVM)).
      constructor 1 with (T := T0); auto.
      apply return_orn; eauto.
      apply wfvm_fail with (WFV := WFV) (Monad_ME := Mon_M); auto.
      apply wfvm_skip with (WFV := WFV) (Fail_MT := Fail_MT) (Monad_ME := Mon_M); auto.
      intro Tt.
      rewrite right_unit at 1.
      apply wfvm_bind with (WFV := WFV) (TypContextCE := TypContextCE); auto.
      intros.
      caseEq (eq_DType D (proj1_sig Tt) T0);
        caseEq (eq_DType D (proj1_sig Tt) T');
        try reflexivity.
      apply eq_DType_eq in H2; apply eq_DType_neq in H4; auto with typeclass_instances; congruence.
      apply eq_DType_neq in H2; apply eq_DType_eq in H4; auto with typeclass_instances; congruence.
      intros.
      caseEq (eq_DType D (proj1_sig Tt) T0).
      apply eq_DType_eq in H4; auto.
      apply (inject_i (subGF := Sub_WFVM_base_WFVM)).
      constructor 1 with (T := T0); auto.
      apply return_orn; eauto.
      apply wfvm_fail with (WFV := WFV) (Monad_ME := Mon_M); auto.
      unfold isTBool.
      rewrite T_eq.
      apply wfvm_fail with (WFV := WFV) (Monad_ME := Mon_M); auto.
    Qed.

  Context {evalM_F : FAlgebra EvalName Exp (evalMR V ME) F}.
  Context {WF_eval_F' : @WF_FAlgebra EvalName _ _ Bool F
    Sub_Bool_F (MAlgebra_evalM_Bool _) evalM_F}.

    Section PSoundness.

      Variable P_bind : Set.
      Variable E' : Set -> Set.
      Context {Fun_E' : Functor E'}.
      Context {Sub_Bool_E' : Bool :<: E'}.

      Variable P : UP'_F F -> UP'_F E' -> P_bind -> TypContext -> Prop.

      Variable If_Decompi :
        forall i1 i2 e1 e2 t1 t2 i1_UP' i2_UP' i1_UP'' i2_UP'' if1_UP' if2_UP' pb Sigma,
          P (exist Universal_Property'_fold
            (in_t (fmap (@proj1_sig _ _) (inj (If _ (exist Universal_Property'_fold i2 i2_UP') t2 e2)))) if2_UP')
          (exist Universal_Property'_fold
            (in_t (fmap (@proj1_sig _ _) (inj (If _ (exist Universal_Property'_fold i1 i1_UP') t1 e1)))) if1_UP')
          pb Sigma ->
          P (exist _ i2 i2_UP'') (exist _ i1 i1_UP'') pb Sigma.

      Variable If_Decompt :
        forall i1 i2 e1 e2 t1 t2 t1_UP' t2_UP' t1_UP'' t2_UP'' if1_UP' if2_UP' pb Sigma,
          P (exist Universal_Property'_fold
            (in_t (fmap (@proj1_sig _ _) (inj (If _ i2 (exist Universal_Property'_fold t2 t2_UP') e2)))) if2_UP')
          (exist Universal_Property'_fold
            (in_t (fmap (@proj1_sig _ _) (inj (If _ i1 (exist Universal_Property'_fold t1 t1_UP') e1)))) if1_UP')
          pb Sigma ->
          P (exist _ t2 t2_UP'') (exist _ t1 t1_UP'') pb Sigma.

      Variable If_Decompe :
        forall i1 i2 e1 e2 t1 t2 e1_UP' e2_UP' e1_UP'' e2_UP'' if1_UP' if2_UP' pb Sigma,
          P (exist Universal_Property'_fold
            (in_t (fmap (@proj1_sig _ _) (inj (If _ i2 t2 (exist Universal_Property'_fold e2 e2_UP'))))) if2_UP')
          (exist Universal_Property'_fold
            (in_t (fmap (@proj1_sig _ _) (inj (If _ i1 t1 (exist Universal_Property'_fold e1 e1_UP'))))) if1_UP')
          pb Sigma ->
          P (exist _ e2 e2_UP'') (exist _ e1 e1_UP'') pb Sigma.

    Global Instance Bool_eval_soundness'
      (P_Sub : forall e e' pb Sigma Sigma',
        P e e' pb Sigma -> ConsExtension Sigma' Sigma ->
        P e e' pb Sigma')
      {WF_Fun_E' : WF_Functor _ _ Sub_Bool_E' _ _}
      {Typeof_E' : forall T, FAlgebra TypeofName T (typeofR D MT) E'}
      {WF_typeof_E' : forall T, @WF_FAlgebra TypeofName T _ _ _
        Sub_Bool_E' (MAlgebra_typeof_Bool T) (Typeof_E' _)}
      (pb : P_bind)
      (eval_rec : Exp -> evalMR V ME)
      (typeof_rec : UP'_F E' -> typeofR D MT)
      :
      P2Algebra ES'_ExpName Bool E' F
      (UP'_P2 (eval_soundness'_P D V F MT ME _ WFVM
        _ _ _ P pb typeof_rec eval_rec (f_algebra (FAlgebra := Typeof_E' _ ))
        (f_algebra (FAlgebra := evalM_F)))).
    Proof.
      apply ind_P2Alg_Bool; eauto.
      (* blit case *)
      unfold eval_soundness'_P, UP'_P2; simpl; intros;
        constructor 1 with (x := conj (proj2_sig (inject' (BLit _ b))) (proj2_sig (inject' (BLit _ b)))).
      unfold inject; simpl; repeat rewrite out_in_fmap;
        repeat rewrite wf_functor; intros.
      WF_FAlg_rewrite.
      apply (inject_i (subGF := Sub_WFVM_base_WFVM));
        constructor 1 with (T := tbool').
      apply inject_i; econstructor; unfold vb; simpl; eauto.
      apply return_orn; eauto.
      (* if case *)
      destruct i as [iE iT]; destruct t as [tE tT]; destruct el as [eE eT];
          destruct IHi as [[UP'_iE UP'_iT] IHi];
            destruct IHt as [[UP'_tE UP'_tT] IHt];
              destruct IHel as [[UP'_eE UP'_eT] IHe];
                simpl in *|-*.
      unfold eval_soundness'_P, UP'_P2; intros.
      assert (Universal_Property'_fold
        (fst
          (inject
            (If (sig Universal_Property'_fold)
              (exist Universal_Property'_fold iE (proj1 (conj UP'_iE UP'_iT)))
              (exist Universal_Property'_fold tE (proj1 (conj UP'_tE UP'_tT)))
              (exist Universal_Property'_fold eE (proj1 (conj UP'_eE UP'_eT)))),
            inject
            (If (sig Universal_Property'_fold)
              (exist Universal_Property'_fold iT (proj2 (conj UP'_iE UP'_iT)))
              (exist Universal_Property'_fold tT (proj2 (conj UP'_tE UP'_tT)))
              (exist Universal_Property'_fold eT (proj2 (conj UP'_eE UP'_eT)))))) /\
        Universal_Property'_fold
        (snd
          (inject
            (If (sig Universal_Property'_fold)
              (exist Universal_Property'_fold iE (proj1 (conj UP'_iE UP'_iT)))
              (exist Universal_Property'_fold tE (proj1 (conj UP'_tE UP'_tT)))
              (exist Universal_Property'_fold eE (proj1 (conj UP'_eE UP'_eT)))),
            inject
            (If (sig Universal_Property'_fold)
              (exist Universal_Property'_fold iT (proj2 (conj UP'_iE UP'_iT)))
              (exist Universal_Property'_fold tT (proj2 (conj UP'_tE UP'_tT)))
              (exist Universal_Property'_fold eT (proj2 (conj UP'_eE UP'_eT))))))) as If_UP'
      by (simpl; split; unfold inject; exact (proj2_sig _)).
      constructor 1 with (x := If_UP'); simpl.
      unfold inject; simpl;
        repeat rewrite out_in_fmap; repeat rewrite wf_functor; simpl.
      intros eval_rec_proj typeof_rec_proj Sigma WF_Sigma IHa.
      repeat rewrite wf_functor; simpl.
      rewrite (wf_algebra (WF_FAlgebra := WF_eval_F'));
        rewrite (wf_algebra (WF_FAlgebra := WF_typeof_E' _));
          simpl fmap; simpl f_algebra; unfold Bool_fmap.
      intros; apply Bool_eval_soundness'_H0.
      intros; generalize (IHa _ _ (exist _ _ UP'_iE, exist _ _ UP'_iT)
        (If_Decompi _ _ _ _ _ _ _ _ _ _ _ _ _ _ WF_Sigma)); simpl.
      rewrite typeof_rec_proj; simpl; intros H'; apply H'.
      apply IHi; auto.
      eapply (If_Decompi _ _ _ _ _ _ _ _ _ _ _ _ _ _ WF_Sigma).
      intros Sigma' ConsExt_Sig'_Sig;
        generalize (IHa _ _ (exist _ _ UP'_tE, exist _ _ UP'_tT)
          (If_Decompt _ _ _ _ _ _ _ _ _ _ _ _ _ _
            (P_Sub _ _ _ _ _ WF_Sigma ConsExt_Sig'_Sig))); simpl.
      rewrite typeof_rec_proj; simpl; intros H'; apply H'.
      apply IHt; auto.
      eapply P_Sub; try eassumption.
      eapply (If_Decompt _ _ _ _ _ _ _ _ _ _ _ _ _ _ WF_Sigma).
      intros Sigma' ConsExt_Sig'_Sig;
        generalize (IHa _ _ (exist _ _ UP'_eE, exist _ _ UP'_eT)
          (If_Decompe _ _ _ _ _ _ _ _ _ _ _ _ _ _
            (P_Sub _ _ _ _ _ WF_Sigma ConsExt_Sig'_Sig))); simpl.
      rewrite typeof_rec_proj; simpl; intros H'; apply H'.
      apply IHe; auto.
      eapply P_Sub; try eassumption.
      eapply (If_Decompe _ _ _ _ _ _ _ _ _ _ _ _ _ _ WF_Sigma).
    Defined.

  End PSoundness.

  Global Instance Bool_eval_soundness'' typeof_rec eval_rec :
    P2Algebra ES'_ExpName Bool F F
    (UP'_P2 (eval_soundness'_P D V F MT ME _ WFVM
      _ _ _ (fun _ _ _ _ => True) tt typeof_rec eval_rec
      (f_algebra (FAlgebra := Typeof_F _)) (f_algebra (FAlgebra := evalM_F)))).
  Proof.
    eapply Bool_eval_soundness'; eauto.
  Defined.

End Bool.

    Ltac WF_invertVB_default :=
      constructor; unfold iAlgebra; intros i H; unfold WF_invertVB_P;
        inversion H; simpl;
          match goal with
            eq_H0 : proj1_sig ?T = _ |- proj1_sig ?T = _ -> _ =>
              intro eq_H; rewrite eq_H in eq_H0;
                elimtype False; eapply (inject_discriminate _ _ _ eq_H0)
          end.

  Hint Extern 5 (iPAlgebra WF_invertVB_Name (WF_invertVB_P _ _ _ _) _) =>
    constructor; unfold iAlgebra; let H := fresh in
      intros i H; unfold WF_invertVB_P;
        inversion H; simpl;
          match goal with
            eq_H0 : proj1_sig ?T = _ |- proj1_sig ?T = _ -> _ =>
              intro eq_H; rewrite eq_H in eq_H0;
                elimtype False; first [apply (inject_discriminate _ _ _ eq_H0) |
                  apply sym_eq in eq_H0; apply (inject_discriminate _ _ _ eq_H0)];
                fail
          end : typeclass_instances.

(* Hint Extern 0 =>
  intros; match goal with
            |- (PAlgebra eval_Soundness_alg_Name
              (sig (UP'_P2 (eval_alg_Soundness_P _ _ _ _ _ _ _ _ _ _ _ _ _ _))) Bool) =>
            eapply Bool_eval_Soundness_alg; eauto with typeclass_instances
          end : typeclass_instances. *)

(*
*** Local Variables: ***
*** coq-prog-args: ("-emacs-U" "-impredicative-set") ***
*** End: ***
*)


Require Import LL.FOLL.Dyadic.CutLElimination.
Require Import LL.FOLL.Dyadic.CutCElimination.
Require Import LL.FOLL.Dyadic.Tactics.
Set Implicit Arguments.

Section CutElimination.
  Context `{OLS: OLSig}.

 Theorem CutElimination i j C A B M N:
      (LL2 i |-- B; C::M -> LL2 j |-- B; (dual C)::N -> LL2 |-- B; M ++ N) /\
      (S (complexity A) = complexity C ->
      LL2 i |-- A::B ; M -> LL2 j |-- B;(! (dual A))::N -> LL2 |-- B; M ++ N).
  Proof with sauto.
    assert(exists w, complexity C = w).
    eexists; auto.
    destruct H as [w H].
    revert H.
    revert i j C A B M N.
    induction w using lt_wf_ind; intros.
    remember (plus i j) as h.
      revert dependent B.
      revert dependent M.
      revert dependent N.
      revert dependent A.
      revert dependent C.

      revert dependent i.
      revert j.
      induction h using lt_wf_ind; intros.
      rename H into CutW.
      rename H0 into CutH.
      rename H1 into compC.

        move B at top.
        move M at top.
        move N at top.
        move C at top.
        move A at top.
        subst.
        rename C into P.
         rename A into Q.
        rename i into a.
        rename j into b.

        split;intros.
       *  eapply (@CutL _ a b P M N)...
          unfold Tactics.CutH; intros.
          eapply CutH with (m:=i+j)...
          unfold Tactics.CutW; intros.
          eapply CutW with (m:=complexity C)...
        * eapply (@CutC _ a b P Q M N)...
          unfold Tactics.CutH; intros.
          eapply CutH with (m:=i+j)...
          unfold Tactics.CutW; intros.
          eapply CutW with (m:=complexity C)...
Qed.

 Theorem CutLL2 i j C B M N:
     LL2 i |-- B; C::M ->
     LL2 j |-- B; (dual C)::N ->
     LL2 |-- B; M ++ N.
 Proof.
    eapply CutElimination;auto.
 Qed.

 Theorem CutLL2' C B M N:
     LL2  |-- B; C::M ->
     LL2 |-- B; (dual C)::N ->
     LL2 |-- B; M ++ N.
 Proof with sauto.
   intros.
   apply LL2StoLL2N in H, H0...
   refine (CutLL2 H H0).
 Qed.

End CutElimination.


Require Import compcert.lib.Coqlib.
Require Import Bvector.
Require Import List.
Require Import compcert.lib.Integers.
Require Import BinNums.
Require Import sha.general_lemmas.
Require Import sha.ByteBitRelations.
Require Import sha.hmac_pure_lemmas.
Require Import sha.HMAC_common_defs.
Require Import sha.HMAC_spec_pad.
Require Import sha.HMAC_spec_concat.
Require Import sha.HMAC_spec_abstract.
Require Import Lia.
Require Import FCF.Blist.
Import List.

Lemma of_length_proof_irrel {A:Set} n (l: list A) M:
      Vector.to_list (@of_list_length _ n l M) = l.
Proof. destruct M. apply Vector.to_list_of_list_opp. Qed.

Require Import sha.HMAC_functional_prog. (*Just for HMAC_FUN*)

Module Type EQUIV_Inst (HF:HP.HASH_FUNCTION).

(*Section EQUIV.*)
  Parameter c:nat.
  Parameter C: NPeano.Nat.divide 8 c.
  Parameter p:nat.
  Definition b := (c+p)%nat.
  Parameter B: (0<b)%nat.
  Parameter BS: (HF.BlockSize * 8)%nat = b.

  Parameter h: Blist -> Blist -> Blist. (*To be instantiated to sha_h*)
  Parameter h_length
     : forall iv blk : list bool,
       length iv = c -> length blk = b -> length (h iv blk) = c. (*instantiation: sha_h_length*)

  Parameter ir: list int.
(*  Definition iv: Blist := convert ir. (*sha_iv*)*)
  Parameter iv_length: length (convert ir) = c. (*sha_iv_length*)
  (*Definition iv_v : Bvector c := of_list_length _ iv_length. (*Vector.of_list iv.*)*)
  Parameter iv_v : Bvector c.
  Parameter iv_eq : convert ir = Vector.to_list iv_v.
(*  Proof. unfold iv_v. rewrite of_length_proof_irrel. trivial.
  Qed.*)

  Parameter fpad_v : Bvector c -> Bvector p.
  Parameter fpad : Blist -> Blist.
  Parameter fpad_length: forall msg, length msg = c -> length (fpad msg) = p.
  Parameter fpad_eq: forall v l, l = Vector.to_list v ->
                    fpad l = Vector.to_list (fpad_v v).

  Parameter splitAndPad : Blist -> Blist.
  Parameter splitAndPad_v : Blist -> list (Bvector b).

  Parameter splitandpad_blocks: Blist -> list Blist.

  Parameter sap_fpad: forall l m, length l = b ->
                     InBlocks 8 m ->
                     splitAndPad (l ++ m) = l ++ HMAC_Concat.app_fpad fpad m.

  Parameter shasplitandpad_blocks_b:
           forall m, Forall (fun x => length x = b) (splitandpad_blocks m).

  Definition sap' (m:Blist):= concat (splitandpad_blocks m). (*plays role of sha_splitandpad_inc*)

  Parameter sap_app : forall (l m : Blist),
                         length l = b ->
                         splitAndPad (l ++ m) = l ++ sap' m.

  Parameter sap'_InBlocks: forall m, InBlocks b (sap' m).

  Parameter hashblock : list int -> list int -> list int.
  Parameter HHB : h =
      (fun rgs bl : Blist =>
       intsToBits (hashblock (bitsToInts rgs) (bitsToInts bl))).

  Parameter hashblocks: list int -> list int -> list int.
  Parameter d:nat.

  Parameter HBS_eq : forall r msg : list int,
         hashblocks r msg =
         match msg with
         | List.nil => r
         | _ :: _ => hashblocks (hashblock r (firstn d msg)) (skipn d msg)
         end.
  Parameter D: (d * 32)%nat = b.

  Parameter gap:list byte -> list int.
  Parameter GAP: forall bits, NPeano.Nat.divide d (length (gap (bitsToBytes bits))).
  Parameter sap_gap: splitAndPad = fun bits => bytesToBits (intlist_to_bytelist (gap (bitsToBytes bits))).

  Parameter HASH: forall m, HF.Hash m = intlist_to_bytelist (hashblocks ir (gap m)).

  Parameter FOLD_HB_eq: forall l ls, length l = (c + p)%nat ->
     Forall (fun x => length x = (c + p)%nat) ls ->
     fold_left h (l :: ls) (Vector.to_list iv_v) =
          hash_blocks_bits (HMAC_spec_concat.HMAC_Concat.b c p) B h
          (Vector.to_list iv_v) (l ++ concat ls).

  Parameter length_splitandpad_inner: forall m,
    Forall2
     (fun (bv : Vector.t bool b) (bl : list bool) => bl = Vector.to_list bv)
     (splitAndPad_v m) (splitandpad_blocks m).
End EQUIV_Inst.

Module HMAC_Equiv (HF:HP.HASH_FUNCTION) (EQ: EQUIV_Inst HF).
Module I<:INST.
  Definition shah : Blist -> Blist ->  Blist := EQ.h.
  Definition hashblock : list int -> list int -> list int :=EQ.hashblock.
  Definition HHB : shah =
      (fun rgs bl : Blist =>
       intsToBits (hashblock (bitsToInts rgs) (bitsToInts bl))) := EQ.HHB.
  Definition hashblocks: list int -> list int -> list int := EQ.hashblocks.
  Definition d:nat := EQ.d.

  Definition HBS_eq : forall r msg : list int,
         hashblocks r msg =
         match msg with
         | List.nil => r
         | _ :: _ => hashblocks (hashblock r (firstn d msg)) (skipn d msg)
         end := EQ.HBS_eq.
End I.

(*Module HM:= HP.HMAC_FUN HF.*)
Module PAD := HMAC_Pad HF I.

  Definition h_v (iv:Bvector EQ.c) (blk:Bvector EQ.b): Bvector EQ.c :=
    of_list_length _
       (EQ.h_length _ _ (VectorToList_length _ iv) (VectorToList_length _ blk)).

  Lemma h_eq : forall (block_v : Bvector EQ.b) (block_l : Blist)
               (HVL: block_l = Vector.to_list block_v)
               ivA ivB (IV: ivA = Vector.to_list ivB),
               EQ.h ivA block_l = Vector.to_list (h_v ivB block_v).
  Proof. intros. unfold h_v, of_list_length.
    destruct (EQ.h_length (Vector.to_list ivB) (Vector.to_list block_v)
      (VectorToList_length EQ.c ivB) (VectorToList_length EQ.b block_v)).
    symmetry. subst. apply Vector.to_list_of_list_opp.
  Qed.

  Definition ipd := Byte.repr 54.
  Definition opd :=Byte.repr 92.

  Definition IPAD:=bytesToBits (PAD.HM.sixtyfour ipd).
  Definition OPAD:=bytesToBits (PAD.HM.sixtyfour opd).

  Lemma IL: length IPAD = EQ.b.
    unfold IPAD. rewrite bytesToBits_len, PAD.HM.length_SF, <- EQ.BS; trivial.
  Qed.
  Lemma OL: length OPAD = EQ.b.
    unfold OPAD. rewrite bytesToBits_len, PAD.HM.length_SF, <- EQ.BS; trivial.
  Qed.

  Definition ipad_v: Bvector EQ.b := of_list_length _ IL.
  Definition opad_v : Bvector EQ.b := of_list_length _ OL.
  Lemma OPADX:bytes_bits_lists (Vector.to_list opad_v) (PAD.HM.sixtyfour opd).
    apply bytes_bits_comp_ind.
      unfold PAD.HM.sixtyfour.
    unfold opad_v. rewrite of_length_proof_irrel. reflexivity.
  Qed.

  Lemma IPADX:bytes_bits_lists (Vector.to_list ipad_v) (PAD.HM.sixtyfour ipd).
    apply bytes_bits_comp_ind.
      unfold PAD.HM.sixtyfour.
    unfold ipad_v. rewrite of_length_proof_irrel. reflexivity.
  Qed.

Lemma BS_pos: (0< HF.BlockSize)%nat.
Proof.
  assert ((0 < HF.BlockSize * 8)%nat).
    rewrite EQ.BS. apply EQ.B.
  lia.
Qed.

  Lemma opad_ne_ipad : opad_v <> ipad_v.
  intros N.
  assert ((Vector.to_list ipad_v)  = bytesToBits (PAD.HM.sixtyfour ipd)  ).
    apply bits_bytes_ind_comp; trivial.
    apply IPADX.
  assert ((Vector.to_list opad_v)  = bytesToBits (PAD.HM.sixtyfour opd)  ).
    apply bits_bytes_ind_comp; trivial.
    apply OPADX.
  rewrite N, H in H0; clear N H.
  apply bytesToBits_injective in H0; trivial.
  unfold PAD.HM.sixtyfour in H0.
  apply repeat_injective in H0. inv H0.
  apply BS_pos.
Qed.

Lemma Equivalence (P : Blist -> Prop) (HP: forall msg, P msg -> NPeano.Nat.divide 8 (length msg))
      (kv : Bvector EQ.b) (m : HMAC_Abstract.Message P):
      Vector.to_list (HMAC_spec.HMAC h_v EQ.iv_v (HMAC_Abstract.wrappedSAP _ _ EQ.splitAndPad_v)
                      EQ.fpad_v opad_v ipad_v kv m) =
      bytesToBits (PAD.HM.HmacCore ipd opd
                     (bitsToBytes (HMAC_Abstract.Message2Blist m))
                     (bitsToBytes (Vector.to_list kv))).
Proof.
  assert (LK : length (Vector.to_list kv) = EQ.b).
    { apply VectorToList_length. }
  erewrite <- HMAC_Abstract.HMAC_abstract_list; try reflexivity.
  2: apply h_eq.
  2: apply EQ.fpad_eq.
  2: apply EQ.length_splitandpad_inner.
  erewrite HMAC_spec_list.HMAC_List.HMAC_list_concat with (B:=EQ.B)(sap':=EQ.sap').
  2: apply EQ.fpad_length.
  2: apply EQ.shasplitandpad_blocks_b.
  2: reflexivity.
  2: apply EQ.h_length.
  2: apply VectorToList_length.
  2: apply VectorToList_length.
  2: apply VectorToList_length.
  2: apply EQ.FOLD_HB_eq.
  2: apply LK.

  erewrite <- HMAC_spec_concat.HMAC_Concat.HMAC_concat_pad.
  2: apply EQ.C.
  5: apply EQ.h_length.
  5: apply VectorToList_length.
  5: apply VectorToList_length.
  5: apply VectorToList_length.
  5: apply VectorToList_length.
  2: apply EQ.sap_app.
  2: apply EQ.sap_fpad.
  2: apply EQ.sap'_InBlocks.
  rewrite <- EQ.iv_eq.
  apply bits_bytes_ind_comp.
  eapply (PAD.HMAC_pad_concrete' _ _ EQ.B EQ.BS EQ.D EQ.ir _ EQ.GAP EQ.sap_gap EQ.HASH).
            erewrite bitsToBytes_len_gen. reflexivity.
            rewrite LK. rewrite EQ.BS; trivial.
            apply bytes_bits_comp_ind.
              rewrite bits_bytes_bits_id; trivial.
              apply InBlocks_len. rewrite LK, <- EQ.BS. eexists; reflexivity.
    apply bytes_bits_comp_ind.
              rewrite bits_bytes_bits_id; trivial.
              apply InBlocks_len. destruct m. simpl. apply HP. assumption.
    apply OPADX. apply IPADX. (*
    apply bytes_bits_comp_ind.
             unfold PAD.HM.sixtyfour. apply Forall_repeat. apply EQ.isbyteZ_Ipad.
             unfold opad_v. rewrite of_length_proof_irrel. reflexivity.
    apply bytes_bits_comp_ind.
             unfold PAD.HM.sixtyfour. apply Forall_repeat. apply EQ.isbyteZ_Ipad.
             unfold ipad_v. rewrite of_length_proof_irrel. reflexivity.*)
Qed.
   (*

Lemma opad_length: length (bytesToBits (HP.HMAC_SHA256.sixtyfour
                       (Integers.Byte.unsigned HP.Opad))) = b.
Proof. rewrite bytesToBits_len, length_SF. reflexivity. Qed.

Definition opad_v: Bvector b := of_list_length _ opad_length.

Lemma ipad_length: length (bytesToBits (HP.HMAC_SHA256.sixtyfour
                       (Integers.Byte.unsigned HP.Ipad))) = b.
Proof. rewrite bytesToBits_len, length_SF. reflexivity. Qed.

Definition ipad_v: Bvector b := of_list_length _ ipad_length.

Lemma Equivalence (P : Blist -> Prop) (HP: forall msg, P msg -> NPeano.divide 8 (length msg))
      (kv : Bvector b) (m : HMAC_Abstract.Message P):
      Vector.to_list (HMAC_spec.HMAC h_v iv_v (HMAC_Abstract.wrappedSAP _ _ splitAndPad_v)
                      fpad_v opad_v ipad_v kv m) =
      bytesToBits (HP.HMAC_SHA256.HmacCore (Integers.Byte.repr 54) (Integers.Byte.repr 92)
                              (bitsToBytes (HMAC_Abstract.Message2Blist m))
                              (map Integers.Byte.repr (bitsToBytes (Vector.to_list kv)))).
Proof.
  assert (LK : length (Vector.to_list kv) = b).
    { apply VectorToList_length. }
  erewrite <- HMAC_Abstract.HMAC_abstract_list; try reflexivity.
  2: apply h_eq.
  2: apply fpad_eq.
  2: apply length_splitandpad_inner.
  rewrite HMAC256_spec_list.HMAC_list_concat_sap_instantiated; trivial.
  2: apply sha_h_length.
  2: apply VectorToList_length.
  2: apply VectorToList_length.
  2: apply fold_hash_blocks_eq.
(*  rewrite <- sha_splitandpad_inc_eq.*)
  rewrite <- HMAC256_spec_concat.HMAC_concat_pad_sap_instantiated; trivial.
  2: apply sha_h_length.
  2: apply VectorToList_length.
  2: apply VectorToList_length.
  eapply HMAC256_spec_pad.HMAC_pad_concrete'.

  split; lia.
  split; lia.

  (* key length *)
  { rewrite map_length, bitsToBytes_len_gen with (n:=64%nat).
    reflexivity.
    rewrite LK; reflexivity. }

  (* key length *)
  { rewrite Zlength_map, bitsToBytes_len. reflexivity. apply LK. }

  (* TODO: maybe replace bytes_bits_lists with bytesToBits? Since bytes_bits_comp_ind
     is used a lot *)

  (* key *)
  { rewrite map_unsigned_Brepr_isbyte.
      apply bytes_bits_comp_ind.
      eapply bitsToBytes_isbyteZ; reflexivity.
      rewrite  bits_bytes_bits_id; trivial.
      apply block_8. assumption.
      eapply bitsToBytes_isbyteZ. reflexivity. }

  (* uses fact that message is in blocks of 8 *)
  { apply bytes_bits_comp_ind.
    eapply bitsToBytes_isbyteZ; reflexivity.
    rewrite bits_bytes_bits_id; trivial.
    apply InBlocks_len.
    apply HP. destruct m. simpl; trivial. }

  (* opad *)
  { apply bytes_bits_comp_ind.
    apply Forall_repeat. unfold HP.Opad. lia.
    apply of_length_proof_irrel. }

  (* ipad *)
  { apply bytes_bits_comp_ind.
    apply Forall_repeat. unfold HP.Ipad. lia.
    apply of_length_proof_irrel. }

Qed.*)
End HMAC_Equiv.


Require Import Coq.micromega.Lia.
Require Import Coq.Arith.Compare_dec.
Import List.ListNotations.

Require Import Leapfrog.P4automaton.
Require Import Leapfrog.FinType.
Require Import Leapfrog.ConfRel.
Require Import Leapfrog.Relations.
Require Leapfrog.Bisimulations.Semantic.
Module BS := Leapfrog.Bisimulations.Semantic.
Require Import Leapfrog.Bisimulations.Upto.

Section UptoProofs.
  Variable (a: p4automaton).
  Notation conf := (configuration a).

  Lemma bisimilar_implies_bisimilar_upto
        (f: rel conf -> rel conf)
    :
      SoundClosure a f ->
      forall c1 c2,
        BS.bisimilar c1 c2 ->
        bisimilar_upto a f c1 c2
  .
  Proof.
    intros.
    destruct H0 as [R [? ?]].
    exists R; split; auto.
    intros c1' c2' ?; split.
    - now apply H0.
    - intros.
      now apply H, H0.
  Qed.

  Lemma bisimilar_upto_implies_bisimilar
        (f: rel conf -> rel conf)
    :
      SoundClosure a f ->
      forall c1 c2,
        bisimilar_upto a f c1 c2 ->
        BS.bisimilar c1 c2
  .
  Proof.
    intros.
    destruct H0 as [R [? ?]].
    exists (f R); split.
    - intros c1' c2' ?; split.
      + revert c1' c2' H2.
        now apply H, H0.
      + revert c1' c2' H2.
        now apply H, H0.
    - now apply closure_sound_extends.
  Qed.

  (* Sanity check: the identity function is a valid closure. *)
  Definition close_id (R: rel conf) := R.

  Program Instance close_id_sound
    : SoundClosure a close_id
  .
  Solve Obligations with firstorder.
End UptoProofs.


Require Import Omega.
Require Import String.
Require Import Lists.List.
Import ListNotations.
Open Scope list_scope.

From Hammer Require Import Reconstr.

(** Syntactical category of reference annotations. It contains
    _rwr_, _rd_ and _atm_ annotations.

    Defined in Figure {fig:syntax} as the set \mmod. *)
Inductive JFAMod : Set :=
| JFrwr
| JFrd
| JFatm.

Definition JFAMod_dec : forall v v' : JFAMod, {v=v'}+{~v=v'}.
  destruct v;destruct v'; try (left;congruence); try (right;congruence).
Defined.
Hint Resolve JFAMod_dec : dec.

(** Partial order on annotations.

    Defined in Section {sec:syntax-semantics}. *)
Inductive leqAnn : JFAMod -> JFAMod -> Prop  :=
| refl:  forall mu, leqAnn mu mu
| rwrrd: leqAnn JFrwr JFrd
| rdatm: leqAnn JFrd JFatm
| rwratm: leqAnn JFrwr JFatm.

Hint Constructors leqAnn : myhints.

Lemma leqAnn_dec:
  forall mu mu',
    leqAnn mu mu' \/ ~leqAnn mu mu'.
Proof.
  destruct mu, mu';sauto.
Qed.

(** Upper bound for annotations.

    Defined in Section {sec:syntax-semantics}. *)
Definition supAnn (mu1 mu2:JFAMod) : JFAMod :=
  match mu1 with
  | JFrwr => mu2
  | JFrd => match mu2 with
            | JFrwr => JFrd
            | JFrd => JFrd
            | JFatm => JFatm
            end
  | JFatm => JFatm
  end.

(** Lower bound for annotations.

    Defined in Section {sec:syntax-semantics}. *)
Definition infAnn (mu1 mu2:JFAMod) : JFAMod :=
  match mu1 with
  | JFrwr => JFrwr
  | JFrd => match mu2 with
            | JFrwr => JFrwr
            | JFrd => JFrd
            | JFatm => JFrd
            end
  | JFatm => mu2
  end.

Lemma rwr_bottom:
  forall mu, leqAnn JFrwr mu.
Proof.
  destruct mu; auto with myhints.
Qed.

Lemma rwr_eq:
  forall mu, leqAnn mu JFrwr -> mu = JFrwr.
Proof.
  intros.
  destruct mu; auto; inversion H.
Qed.

Lemma atm_top:
  forall mu, leqAnn mu JFatm.
Proof.
  intros.
  destruct mu; auto with myhints.
Qed.

Lemma atm_eq:
  forall mu, leqAnn JFatm mu -> mu = JFatm.
Proof.
  intros.
  destruct mu; auto; inversion H.
Qed.

Lemma leqAnn_trans:
  forall (mu1 mu2 mu3:JFAMod),
    leqAnn mu1 mu2 -> leqAnn mu2 mu3 -> leqAnn mu1 mu3.
Proof.
  scrush.
Qed.

Lemma infAnn_leq_l:
  forall mu1 mu2 mu3,
    infAnn mu1 mu2 = mu3 ->
    leqAnn mu3 mu1.
Proof.
  scrush.
Qed.

Lemma infAnn_leq_r:
  forall mu1 mu2 mu3,
    infAnn mu1 mu2 = mu3 ->
    leqAnn mu3 mu2.
Proof.
  scrush.
Qed.

Lemma infAnn_inf:
  forall mu1 mu2 mu,
      leqAnn mu mu1 ->
      leqAnn mu mu2 ->
      leqAnn mu (infAnn mu1 mu2).
Proof.
  scrush.
Qed.

Hint Resolve atm_top rwr_bottom leqAnn_trans infAnn_leq_l infAnn_leq_r infAnn_inf: myhints.

(**
   Effective version of the partial order on annotations that
   returns booleans instead predicting the property.
*)
Fixpoint leqAnn_bool (mu1 mu2:JFAMod) : bool  :=
  match mu1 with
    | JFrwr => true
    | JFrd => match mu2 with
                | JFrwr => false
                | _ => true
              end
    | JFatm => match mu2 with
                 | JFatm => true
                 | _ => false
               end
  end.

(**
   The reverse of the effective version of the partial order on
   annotations. It returns booleans instead predicting the property.
*)
Definition geqAnn_bool mu1 mu2 := leqAnn_bool mu2 mu1.

(** Alias name for class names. We represet them as
    Coq strings. *)
Definition JFClassName := string.

Hint Resolve string_dec : dec.

(** Decidable equality on [JFClassName]. *)
Definition JFClassName_dec : forall v v' : JFClassName, {v=v'}+{~v=v'}.
  exact string_dec.
Defined.
Hint Resolve JFClassName_dec : dec.

Lemma jfclassname_commutative:
  forall cn dn,
    (if JFClassName_dec cn dn then true else false) =
    if JFClassName_dec dn cn then true else false.
Proof.
  scrush.
Qed.

(** Syntactical category of class identifiers. The
  identifier JFBotClass does not occur in the source
  code.

  Defined in Figure {fig:syntax} as the set \Cname. *)
Inductive JFCId : Set :=
| JFClass (cn:JFClassName)
| JFBotClass.

(** Decidable equality on [JFCId]. *)
Definition JFCId_dec : forall v v' : JFCId, {v=v'}+{~v=v'}.
  decide equality.
  auto with dec.
Defined.
Hint Resolve JFCId_dec : dec.

(** The class name of the _Object_ class.

    Defined in Figure {fig:auxiliary-notation} in
    the second row as \objecttype. *)
Definition JFObjectName := "Object"%string.

(** The class name of the _NullPointerException_ class.

    Defined in Figure {fig:auxiliary-notation} in
    the second row as \npetype. *)
Definition JFNPEName := "NullPointerException"%string.

(** The class identifier of _Object_. *)
Definition JFObject := JFClass (JFObjectName).

(** The class identifier of _NullPointerException_. *)
Definition JFNPE := JFClass (JFNPEName).

(** Syntactical category of method identifiers.

  Defined in Figure {fig:syntax} as the set _m_. *)
Definition JFMId := string.

(** Decidable equality on [JFMId]. *)
Definition JFMId_dec : forall v v' : JFMId, {v=v'}+{~v=v'}.
  exact string_dec.
Defined.
Hint Resolve JFMId_dec : dec.

(** Syntactical category of variable identifiers.

  Defined in Figure {fig:syntax} as the set _x_. *)
Definition JFXId := string.

(** Decidable equality on [JFCId]. *)
Definition JFXId_dec : forall v v' : JFXId, {v=v'}+{~v=v'}.
  exact string_dec.
Defined.
Hint Resolve JFXId_dec : dec.

(** Semantical category of locations. It is defined in the
    syntax part since the small step reduction of Jafun
    semantics uses locations in expressions being reduced.
    Locations are either the _null_ location or an address.

    Defined in Section {sec:syntax-semantics} as the set \Loc. *)
Inductive Loc : Set :=
| null
| JFLoc (n:nat).

Hint Resolve Nat.eq_dec : dec.

(** Decidable equality on locations [Loc]. *)
Definition Loc_dec : forall l l' : Loc, {l=l'}+{~l=l'}.
  decide equality.
  auto with dec.
Defined.
Hint Resolve Loc_dec : dec.

(** Syntactic reference: variable or _this_. *)
Inductive JFRef :=
| JFVar (x:JFXId)
| JFThis.

(** Decidable equality on references [JFRef]. *)
Definition JFRef_dec : forall v v' : JFRef, {v=v'}+{~v=v'}.
  decide equality.
  auto with dec.
Defined.
Hint Resolve JFRef_dec : dec.

(** Values: locations or syntactic references *)
Inductive JFVal :=
| JFVLoc (l:Loc)
| JFSyn (x:JFRef).

(* now substitutions substitute locations for syntactic references *)

(** "Syntactic" _null_ is directly represented by the "semantic" one. *)
Notation JFnull := (JFVLoc null).

(** Decidable equality on primitive values [JFVal]. *)
Definition JFVal_dec : forall v v' : JFVal, {v=v'}+{~v=v'}.
  decide equality; auto with dec.
Defined.
Hint Resolve JFVal_dec : dec.

(** Check if the value is a location. *)
Definition isLoc (v:JFVal) :=
match v with
| JFnull => True
| JFVLoc (JFLoc _) => True
| JFSyn _ => False
end.

(** Check if the value is _null_. *)
Definition isNonNullLoc (v:JFVal) :=
match v with
| JFnull => False
| JFVLoc (JFLoc _) => True
| JFSyn _ => False
end.

(**
   The representation of subexpression in which an object refers to
   its field. This is a type of subexpressions that helps to define
   the main syntactic category.
 *)
Definition JFFieldref :Set :=  (JFVal * JFXId)%type.

(** The representation of Jafun expressions.

    Defined in Figure {fig:syntax} as the syntactic
    category _E_. *)
Inductive JFExpr : Set :=
| JFNew (mu:JFAMod) (cn:JFClassName) (vs : list JFVal)
| JFLet (cn:JFClassName) (x:JFXId) (E1:JFExpr) (E2:JFExpr)
| JFIf (v1 v2:JFVal) (E1:JFExpr) (E2:JFExpr)
| JFInvoke (v:JFVal) (m:JFMId) (vs:list JFVal)
| JFAssign (vx:JFFieldref) (v:JFVal)
| JFVal1 (v:JFVal)
| JFVal2 (vx:JFFieldref)
| JFThrow (v:JFVal)
| JFTry (E1:JFExpr) (mu:JFAMod) (cn:JFClassName) (x:JFXId) (E2:JFExpr).

(* make an alpha equivalent of [x.E] not using [vv]; TODO: maybe this should return a pair *)
Parameter alphaExpr : forall (x:JFXId) (vv:list JFXId) (E:JFExpr), JFExpr.
Parameter alphaVal : forall (x:JFXId) (vv:list JFXId) (E:JFVal), JFVal.

(** Substitute the value [l] for [v] in [x] (i.e. _"x{l/v}"_). *)
Definition substVal (v : JFRef) (l:Loc) (x : JFVal) :=
  match x with
  | JFVLoc _ => x
  | JFSyn y => if JFRef_dec v y then JFVLoc l else x
  end.

(** Substitute the location [l] for the occurrences of the reference [v]
    in the expression [E] (i.e. _"E{l/v}"_).
 *)
Fixpoint substExpr (v:JFRef) (l:Loc) (E:JFExpr) {struct E} : JFExpr :=
  match E with
  | JFNew mu C vs => JFNew mu C (List.map (substVal v l) vs)
  | JFLet C x E1 E2 =>
    if JFRef_dec (JFVar x) v then
      JFLet C x (substExpr v l E1) E2
    else
      JFLet C x (substExpr v l E1) (substExpr v l E2)
  | JFIf v1 v2 E1 E2 =>
    JFIf (substVal v l v1) (substVal v l v2)
         (substExpr v l E1) (substExpr v l E2)
  | JFInvoke v1 m vs =>
    JFInvoke (substVal v l v1) m (List.map (substVal v l) vs)
  | JFAssign (v1,fld) v2 =>
    JFAssign (substVal v l v1, fld) (substVal v l v2)
  | JFVal1 v1 =>
    JFVal1 (substVal v l v1)
  | JFVal2 (v1, fld) =>
    JFVal2 (substVal v l v1, fld)
  | JFThrow v1 =>
    JFThrow  (substVal v l v1)
  | JFTry E1 mu C x E2 =>
    if JFRef_dec (JFVar x) v then
      JFTry (substExpr v l E1) mu C x E2
    else
      JFTry (substExpr v l E1) mu C x (substExpr v l E2)
  end.

(** Substitute the variables from the list [vs] by respective values
    in the list [fs] in [E] (i.e. _"E{fs/vs}"_).
 *)
(* Fixpoint substList fs vs E {struct fs} :=
  match fs with
    | [] => Some E
    | v1 :: tl =>
      match vs with
        | [] => None
        | v2 :: tl' =>
          match v2 with
            | JFVLoc l => substList tl tl' (substExpr v1 l E)
            | _ => None
          end
      end
  end.
 *)
Fixpoint substList fs vs E {struct fs} :=
  match (fs, vs) with
    | ([], []) => Some E
    | (v1 :: tl, v2::tl') =>
        match v2 with
          | JFVLoc l => substList tl tl' (substExpr v1 l E)
          | _ => None
        end
    | _ => None
  end.

(** A class type combinded with an annotation.

    The type system uses the pairs in the
    sequence: class first, annotation second. *)
Definition JFACId : Set := (JFCId * JFAMod)%type.

Definition JFACId_dec : forall v v' : JFACId, {v=v'}+{~v=v'}.
  decide equality; auto with dec.
Defined.
Hint Resolve JFACId_dec : dec.

(** The representation of method declarations. There are two kinds
    of declarations: with access mode annotations (local state ones)
    [JFMDecl] and without [JFMDecl0].

    Defined in Figure {fig:syntax} as the syntactic
    category \mathbf{M}.
 *)
Inductive JFMethodDeclaration : Set :=
| JFMDecl (C:JFACId) (mu:JFAMod) (m:JFMId) (vs:list (JFXId * JFACId)) (thrws:list JFACId) (E:JFExpr)
| JFMDecl0 (C:JFCId) (m:JFMId) (vs:list (JFXId * JFCId)) (thrws:list JFCId) (E:JFExpr).

(** Decidable equality on method declarations [JFMethodDeclaration]. *)
Definition JFMethodDeclaration_dec : forall v v' : JFMethodDeclaration, {v=v'}+{~v=v'}.
  repeat (decide equality; auto with dec).
Defined.
Hint Resolve JFMethodDeclaration_dec : dec.

Section methodProjections.

(** Retrives the type of the value returned from the given
    method declared as [md]. *)
Definition rettyp_of_md (md: JFMethodDeclaration) : JFACId :=
  match md with
  | JFMDecl cn mu mn vs excs E => cn
  | JFMDecl0 cn mn vs excs E => (cn, JFrwr)
  end.

(** Retrives the annotation of _this_ for the given
    method declared as [md]. It returns [Some] value in case
    the method is local-sensitive and [None] otherwise. *)
Definition mode_of_md (md: JFMethodDeclaration) : option JFAMod :=
  match md with
  | JFMDecl cn mu mn vs excs E => Some mu
  | JFMDecl0 cn mn vs excs E => None
  end.

(** Retrives the name of the method from the given
    method declaration [md]. *)
Definition name_of_md (md: JFMethodDeclaration) : JFMId :=
  match md with
  | JFMDecl _ _ mn _ _ _ => mn
  | JFMDecl0 _ mn _ _ _ => mn
  end.

(** Retrives the formal parameters of the method from the given
    method declaration [md]. *)
Definition params_of_md md :=
  match md with
    | JFMDecl _ _ _ vs _ _ => map fst vs
    | JFMDecl0 _ _ vs _ _ => map fst vs
  end.

(** Retrives the list of types of exceptions being thrown by
    the method [md]. The function returns an annotated type, i.e.
    [JFACid]. In case of non-local sensitive methods it returns
    _rwr_ annotations. *)
Definition thrs_of_md (md: JFMethodDeclaration) : list JFACId :=
  match md with
  | JFMDecl cn mu mn vs excs E => excs
  | JFMDecl0 cn mn vs excs E => map (fun dn => (dn, JFrwr)) excs
  end.

(** Retrives the expression which is the body of the given
    method declaration [md]. *)
Definition body_of_md (md:JFMethodDeclaration) : JFExpr :=
  match md with
    | JFMDecl _ _ _ _ _ E => E
    | JFMDecl0 _ _ _ _ E => E
  end.

(** Checks if the given method [md] is a declaration of a local-sensitive
    method. The method checks the way the declaration [md] is constructed. *)
Definition isLS (md:JFMethodDeclaration) : Prop :=
  match md with
  | JFMDecl _ _ _ _ _ _ => True
  | JFMDecl0 _ _ _ _ _ => False
  end.

Lemma isLS_dec : forall md, {isLS md} + {~isLS md}.
Proof.
  destruct md; simpl; auto.
Qed.
End methodProjections.

(** Finds a declaration of a method with the given name [m] in
    the list of method declarations [mthds]. It returns [None] in
    case there is no method declaration of the given name and
    [Some] value in case the method declaration is found. *)
Fixpoint find_method mthds m {struct mthds} :=
  match mthds with
    | [] => None
    | (JFMDecl cn mu mn vs excs E) :: tl =>
      if JFMId_dec m mn
      then Some (JFMDecl cn mu mn vs excs E)
      else find_method tl m
    | (JFMDecl0 cn mn vs excs E) :: tl =>
      if JFMId_dec m mn
      then Some (JFMDecl0 cn mn vs excs E)
      else find_method tl m
  end.

(** Syntactical category of field declarations.
    The _phi_ argument is [true] when there is a _rep_
    modifier attached to the field. It is [false] otherwise.

  Defined in Figure {fig:syntax} as the set \mathbf{F}.
 *)
Inductive JFFieldDeclaration : Set :=
| JFFDecl (phi:bool) (C:JFCId) (x:JFXId).

(** Decidable equality on field declarations [JFFieldDeclaration]. *)
Definition JFFieldDeclaration_dec : forall v v' : JFFieldDeclaration, {v=v'}+{~v=v'}.
  repeat decide equality.
Defined.

Section fieldProjections.

(** Retrives the name of the given field [fd]. *)
Definition name_of_fd fd :=
  match fd with
    | JFFDecl _ _ x => x
  end.

(** Retrives the class of the given field [fd]. *)
Definition class_of_fd fd :=
  match fd with
    | JFFDecl _ Cid _ => Cid
  end.

(** Retrives the annotation of the given field [fd]. *)
Definition ann_of_fd fd :=
  match fd with
    | JFFDecl phi _ _ => phi
  end.

End fieldProjections.

(** Syntactical category of class declarations.

    Defined in Figure {fig:syntax} as the set \mathbf{C}.

    As written in Java Language Specification Section 8.1.4,
    the extends clause is optional. This is modelled by the
    *option* type in the argument [ex].
 *)
Inductive JFClassDeclaration : Set :=
| JFCDecl (cn:JFClassName) (ex:option JFClassName)
          (fields:list JFFieldDeclaration) (methods:list JFMethodDeclaration).

(** Decidable equality on class declarations [JFClassDeclaration]. *)
Definition JFClassDeclaration_dec : forall v v' : JFClassDeclaration, {v=v'}+{~v=v'}.
  repeat decide equality.
Defined.

Section classProjections.

(** Retrives the name of the given class [cd]. *)
Definition name_of_cd (cd: JFClassDeclaration) :=
  match cd with
  | JFCDecl cn _ _ _ => cn
  end.

(** Retrives the field declarations in the given class [cd].
    This method does not traverse the inheritance hierarchy. *)
Definition flds_of_cd (cd: JFClassDeclaration) :=
  match cd with
  | JFCDecl _ _ fields _ => fields
  end.

(** Retrives the method declarations in the given class [cd].
    This method does not traverse the inheritance hierarchy. *)
Definition mthds_of_cd (cd: JFClassDeclaration) :=
  match cd with
  | JFCDecl _ _ _ mthds => mthds
  end.

(** Retrives the extends clause in the given class [cd].
    It returns [None] in case the current class is not extended.
    This should happen only in the case of the [Object] class. *)
Definition extds_of_cd (cd:JFClassDeclaration) :=
  match cd with
  | JFCDecl _ extds _ _ => extds
  end.

End classProjections.

(** The general structure of Jafun programs. It is a list of classes.
    We assume the preloading view, where programs come as a list. *)
Definition JFProgram : Set := list JFClassDeclaration.

(** Finds a declaration of a class with the given name [cn] in
    the program [CC]. It returns [None] in case there is no class
    declaration of the given name and [Some] value in case the class
    declaration is found. *)
Fixpoint find_class (CC:JFProgram) (cn:JFClassName) :=
  match CC with
  | [] => None
  | (JFCDecl dn ex fields methods) :: CC' =>
    if (JFClassName_dec dn cn)
    then Some (JFCDecl dn ex fields methods)
    else find_class CC' cn
  end.

Lemma find_class_eq:
  forall CC cn ex fields methods,
    find_class (JFCDecl cn ex fields methods :: CC) cn =
    Some (JFCDecl cn ex fields methods).
Proof.
  sauto.
Qed.

Lemma find_class_further_neq:
  forall CC cn dn  ex fields methods cd,
  cn<>dn ->
  find_class (JFCDecl cn ex fields methods :: CC) dn = Some cd ->
  find_class CC dn = Some cd.
Proof.
  sauto.
Qed.

Lemma find_class_in:
  forall CC cn dn ex fields methods,
    find_class CC cn = Some (JFCDecl dn ex fields methods) ->
    In (JFCDecl cn ex fields methods) CC.
Proof.
  induction CC; sauto.
Qed.

Lemma find_class_same:
  forall CC cn dn ex fields methods cd,
  cn <> dn ->
  find_class CC dn = Some cd ->
  find_class (JFCDecl cn ex fields methods :: CC) dn = Some cd.
Proof.
  sauto.
Qed.

Lemma find_class_eq_name:
  forall CC cn dn ex fields methods,
  find_class CC cn = Some (JFCDecl dn ex fields methods) ->
  cn = dn.
Proof.
  induction CC; sauto.
Qed.
Check find_class.
Lemma find_class_decompose_program:
  forall CC cn cd,
    find_class CC cn = Some cd ->
    exists CC0 CC1,
      CC = CC0 ++ (cd :: CC1).
Proof.
  induction CC; sauto.
  +  exists [], CC; auto.
  +  assert (exists CC0 CC1 : list JFClassDeclaration,
                CC = CC0 ++ cd :: CC1) by eauto.
     destruct H0 as [CC0 [CC1 HH]].
     exists (JFCDecl cn0 ex fields methods :: CC0), CC1.
     sauto.
Qed.

Lemma find_class_lift_cons:
  forall CC cn cd dd,
    find_class CC cn = Some cd ->
    exists cd',
      find_class (dd :: CC) cn = Some cd'.
Proof.
  sauto.
Qed.

Lemma find_class_lift:
  forall CC1 CC2 cn cd,
    find_class CC2 cn = Some cd ->
    exists cd',
      find_class (CC1 ++ CC2) cn = Some cd'.
Proof.
  induction CC1; sauto.
Qed.

Lemma find_class_lift_cons_inside:
  forall CC1 CC2 cn cd dd,
    find_class (CC1 ++ CC2) cn = Some cd ->
    exists cd',
      find_class (CC1 ++ dd::CC2) cn = Some cd'.
Proof.
  induction CC1; sauto.
Qed.

(** Checks if the given program [P] contains a class declaration of the
    given name [cname].
*)
Fixpoint program_contains (CC:JFProgram) (cn:JFClassName) : bool :=
  match CC with
    | [] => false
    | JFCDecl dn _ _ _ :: CC' => if JFClassName_dec cn dn then true else program_contains CC' cn
  end.

Lemma program_contains_further_neq:
  forall CC cn dn ex fields methods,
    cn <> dn ->
    program_contains (JFCDecl cn ex fields methods :: CC) dn = true ->
    program_contains CC dn = true.
Proof.
  sauto.
Qed.

Lemma program_contains_further:
  forall CC cn dn ex fields methods,
    program_contains CC dn = true ->
    program_contains (JFCDecl cn ex fields methods :: CC) dn = true.
Proof.
  sauto.
Qed.

Lemma program_contains_find_class:
  forall CC cn,
    program_contains CC cn = true ->
    exists cd, find_class CC cn = Some cd.
Proof.
  induction CC; sauto.
Qed.

Lemma find_class_program_contains:
  forall CC cn cd,
    find_class CC cn = Some cd ->
    program_contains CC cn = true.
Proof.
  induction CC; sauto.
Qed.

(** Finds the method [m] in the class of the name [cn] in the program [CC],
    traversing the inheritance hierarchy of [cn] in the program [CC].
    In case the program [CC] does not contain a class with name [cn]
    the function returns [None]. In case the class does not contain
    the method [m], it returns [None] too. Otherwise, [Some] method
    declaration is returned.
*)
Fixpoint methodLookup (CC:JFProgram) (cn:JFClassName)
           (m:JFMId)  : option JFMethodDeclaration :=
  match CC with
  | [] => None
  | (JFCDecl dn ex _ mthds) :: CC1 =>
    if JFClassName_dec cn dn
    then match find_method mthds m with
         | None => match ex with
                   | None => None
                   | Some en => methodLookup CC1 en m
                   (* Correction: semantically CC in place of CC1
                      changes the meaning in case cn=dn=en and there
                              is no m in mthds, which occurs only in
                              non-wellformeed programs. So we can
                              redefine it. *)
                   end
         | Some md => Some md
         end
    else
      methodLookup CC1 cn m
  end.

Lemma methodLookup_raw_empty:
  forall cn m,
    methodLookup [] cn m = None.
Proof.
  intros. simpl; auto.
Qed.

Lemma methodLookup_prog_monotone_eq:
  forall CC dd cn dn m md,
    cn = (name_of_cd dd) ->
    find_method (mthds_of_cd dd) m = None ->
    extds_of_cd dd = Some dn ->
    methodLookup CC dn m = Some md ->
    methodLookup (dd :: CC) cn m = Some md.
Proof.
  sauto.
Qed.

Lemma methodLookup_raw_neq:
  forall cn dn CC m md fields methods,
    cn <> dn ->
    methodLookup CC dn m = Some md ->
    methodLookup (JFCDecl cn (Some dn) fields methods :: CC) dn m = Some md.
Proof.
  sauto.
Qed.

Lemma methodLookup_find_class:
  forall CC cn m mdcl,
    methodLookup CC cn m = Some mdcl ->
    exists cdcl, find_class CC cn = Some cdcl.
Proof.
  induction CC; sauto.
Qed.

(** Predicate that checks if the given method in the class declaration
    is local sensitive. *)
Inductive isLSForId : JFProgram -> JFClassName -> JFMId -> Prop  :=
| isLStrue : forall CC cn m md,
    methodLookup CC cn m = Some md  ->
    isLS md ->
    isLSForId CC cn m.

Lemma isLSForId_dec:
  forall CC cn m, isLSForId CC cn m \/ ~ isLSForId CC cn m.
Proof.
  intros.
  destruct (methodLookup CC cn m) eqn:?.
  + destruct j.
    ++ pose isLStrue; scrush.
    ++ right; intro H; inversion H; scrush.
  + scrush.
Qed.

Lemma isLSForId_neg:
  forall CC cn m md,
    ~ isLSForId CC cn m ->
    ~ (methodLookup CC cn m = Some md  /\ isLS md).
Proof.
  intros.
  intro.
  apply H.
  destruct H0.
  eapply isLStrue;eauto.
Qed.

Hint Resolve find_class_eq find_class_in isLSForId_dec find_class_lift_cons find_class_lift isLSForId_neg: myhints.


From Coq Require Import
     Ascii String List OrderedType.
Import ListNotations.

(* Convert between strings and lists. *)

Fixpoint list_of_string (s : string) : list ascii :=
  match s with
  | ""%string => []
  | String c s => c :: list_of_string s
  end.

Fixpoint string_of_list (cs : list ascii) : string :=
  match cs with
  | [] => ""%string
  | c :: cs => String c (string_of_list cs)
  end.

(* [ascii] as an [OrderedType]. *)

Class Ordered (T : Type) : Type := {
  lt : T -> T -> Prop;
}.

Class OrderedGood (T : Type) `{Ordered T} : Type := {
  lt_trans : forall t1 t2 t3, lt t1 t2 -> lt t2 t3 -> lt t1 t3;
  lt_not_eq : forall t1 t2, lt t1 t2 -> t1 <> t2;
}.

Class Comparable (T : Type) `{Ordered T} : Type := {
  compare : forall t1 t2, OrderedType.Compare lt eq t1 t2;
}.

Instance Ordered_bool : Ordered bool := {
  lt b1 b2 := b1 = false /\ b2 = true;
}.

Instance OrderedGood_bool : OrderedGood bool := {}.
Proof.
  - firstorder.
  - firstorder; subst; auto.
Qed.

Instance Comparable_bool : Comparable bool := {
  compare b1 b2 :=
    match b1, b2 return OrderedType.Compare _ _ b1 b2 with
    | true, true => EQ eq_refl
    | true, false => GT (conj eq_refl eq_refl)
    | false, true => LT (conj eq_refl eq_refl)
    | false, false => EQ eq_refl
    end
}.

Instance Ordered_pair (T1 T2 : Type)
         `{H1 : Ordered T1} `{H2 : Ordered T2} : Ordered (T1 * T2) := {
  lt p1 p2 := lt (fst p1) (fst p2) \/
              (fst p1 = fst p2 /\ lt (snd p1) (snd p2));
}.

Instance OrderedGood_pair (T1 T2 : Type)
         `{H1 : OrderedGood T1} `{H2 : OrderedGood T2} :
  OrderedGood (T1 * T2).
Proof.
  destruct H1 as [lt_trans1 lt_not_eq1], H2 as [lt_trans2 lt_not_eq2].
  constructor.
  { intros t1 t2 t3 [H12 | [H12 H12']] [H23 | [H23 H23']].
    - left; eapply lt_trans1; eauto.
    - left; rewrite <- H23; auto.
    - left; rewrite H12; auto.
    - right; split.
      + etransitivity; eauto.
      + eapply lt_trans2; eauto.
  }
  { intros t1 t2 [H12 | [H12 H12']] t_eq; subst.
    - eapply lt_not_eq1; eauto.
    - eapply lt_not_eq2; eauto.
  }
Qed.

Instance Comparable_pair (T1 T2 : Type)
         `{Comparable T1} `{Comparable T2} : Comparable (T1 * T2) := {
  compare t1 t2 :=
    match compare (fst t1) (fst t2) with
    | EQ Heq1 =>
      match compare (snd t1) (snd t2) with
      | EQ Heq2 => _
      | GT Hgt2 => _
      | LT Hlt2 => _
      end
    | GT Hgt1 => _
    | LT Hlt1 => _
    end;
}.
Proof.
  - firstorder.
  - firstorder.
  - apply EQ; destruct t1, t2; f_equal; auto.
  - apply GT; firstorder.
  - apply GT; firstorder.
Defined.

Definition tuple_of_ascii :=
  fun '(Ascii a b c d e f g h) => (a, b, c, d, e, f, g, h).

Lemma tuple_of_ascii_inj : forall t1 t2,
    tuple_of_ascii t1 = tuple_of_ascii t2 ->
    t1 = t2.
Proof.
  intros [] [] H; inversion H; auto.
Qed.

Module Ascii_OT <: OrderedType.OrderedType.
   Definition t : Type := ascii.
   Definition eq : t -> t -> Prop := eq.

   Definition lt : t -> t -> Prop :=
     fun t1 t2 => lt (tuple_of_ascii t1) (tuple_of_ascii t2).

   Definition eq_refl : forall x : t, eq x x := @eq_refl _.
   Definition eq_sym : forall x y : t, eq x y -> eq y x := @eq_sym _.
   Definition eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z := @eq_trans _.

   Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z.
   Proof.
     intros [] [] [].
     apply lt_trans.
   Qed.

   Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
   Proof.
     intros [] [] lt_t eq_ascii.
     apply lt_not_eq in lt_t.
     apply lt_t.
     inversion eq_ascii; auto.
   Qed.

   Lemma compare : forall x y : t, OrderedType.Compare lt eq x y.
   Proof.
     intros t1 t2.
     destruct (compare (tuple_of_ascii t1) (tuple_of_ascii t2)).
     - apply LT. auto.
     - apply EQ. apply tuple_of_ascii_inj; auto.
     - apply GT. auto.
   Defined.

   Definition eq_dec : forall x y : t, {eq x y} + {~ eq x y}.
   Proof.
     intros t1 t2.
     destruct (compare t1 t2).
     - right. apply lt_not_eq; auto.
     - left; auto.
     - right. intro H; symmetry in H; apply lt_not_eq in H; auto.
   Defined.
End Ascii_OT.

Definition eqb_ascii (a b : ascii) : bool :=
  if Ascii_OT.eq_dec a b then true else false.

Lemma eqb_eq (a b : ascii) : eqb_ascii a b = true <-> a = b.
Proof.
  unfold eqb_ascii.
  destruct Ascii_OT.eq_dec; split; auto. discriminate.
Qed.

Lemma neqb_neq (a b : ascii) : eqb_ascii a b = false <-> a <> b.
Proof.
  rewrite <- eqb_eq, Bool.not_true_iff_false; reflexivity.
Qed.


(*CompCert imports*)
Require Import Events.
Require Import Memory.
Require Import Coqlib.
Require Import compcert.common.Values.
Require Import Maps.
Require Import Integers.
Require Import AST.
Require Import Globalenvs.

Require Import Axioms.
Require Import sepcomp.mem_lemmas. (*needed for definition of mem_forward etc*)
Require Import sepcomp.core_semantics.
Require Import sepcomp.forward_simulations.

Import Forward_simulation_inj_exposed.

(** * Safety and semantics preservation *)

(** ** Definition of safety w/r/t predicate P *)

Section safety.
Context { G C D Z : Type }
        (Hcore : CoreSemantics G C mem )
        (ge : G)
        (P : val -> mem -> Prop).

Fixpoint safeN (n:nat) (c:C) (m:mem) : Prop :=
  match n with
    | O => True
    | S n' =>
      match halted Hcore c with
        | None =>
          exists c', exists m',
            corestep Hcore ge c m c' m' /\
            safeN n' c' m'
        | Some i => P i m
      end
  end.

Definition corestep_fun  :=
  forall ge m q m1 q1 m2 q2 ,
    corestep Hcore ge q m q1 m1 ->
    corestep Hcore ge q m q2 m2 ->
    (q1, m1) = (q2, m2).

Lemma safe_downward1 :
  forall n c m,
    safeN (S n) c m -> safeN n c m.
Proof.
  induction n; simpl; intros; auto.
  destruct (halted Hcore c); auto.
  destruct H as [c' [m' [? ?]]].
  exists c', m'; split; auto.
Qed.

Lemma safe_downward :
  forall (n n' : nat) c m,
    le n' n ->
    safeN n c m -> safeN n' c m.
Proof.
  do 6 intro. revert c m H0. induction H; auto.
  intros. apply IHle. apply safe_downward1. auto.
Qed.

Lemma safe_corestep_forward:
  corestep_fun ->
  forall c m c' m' n,
    corestep Hcore ge c m c' m' -> safeN (S n) c m -> safeN n c' m'.
Proof.
  simpl; intros.
  erewrite corestep_not_halted in H1; eauto.
  destruct H1 as [c'' [m'' [? ?]]].
  assert ((c',m') = (c'',m'')).
  eapply H; eauto.
  inv H3; auto.
Qed.

Lemma safe_corestepN_forward:
  corestep_fun ->
  forall c m c' m' n n0,
    corestepN Hcore ge n0 c m c' m' -> safeN (n + S n0) c m -> safeN n c' m'.
Proof.
  intros.
  revert c m c' m' n H0 H1.
  induction n0; intros; auto.
  simpl in H0; inv H0.
  eapply safe_downward in H1; eauto. omega.
  simpl in H0. destruct H0 as [c2 [m2 [STEP STEPN]]].
  apply (IHn0 _ _ _ _ n STEPN).
  assert (Heq: (n + S (S n0) = S (n + S n0))%nat) by omega.
  rewrite Heq in H1.
  eapply safe_corestep_forward in H1; eauto.
Qed.

Lemma safe_corestep_backward:
  forall c m c' m' n,
    corestep Hcore ge c m c' m' -> safeN (n - 1) c' m' -> safeN n c m.
Proof.
  simpl; intros.
  induction n; simpl; auto.
  erewrite corestep_not_halted; eauto.
  exists c', m'; split; auto.
  assert (Heq: (n = S n - 1)%nat) by omega.
  rewrite Heq; auto.
Qed.

Lemma safe_corestepN_backward:
  forall c m c' m' n n0,
    corestepN Hcore ge n0 c m c' m' -> safeN (n - n0) c' m' -> safeN n c m.
Proof.
  simpl; intros.
  revert c m c' m' n H H0.
  induction n0; intros; auto.
  simpl in H; inv H.
  solve[assert (Heq: (n = n - 0)%nat) by omega; rewrite Heq; auto].
  simpl in H. destruct H as [c2 [m2 [STEP STEPN]]].
  assert (H: safeN (n - 1 - n0) c' m').
  eapply safe_downward in H0; eauto. omega.
  specialize (IHn0 _ _ _ _ (n - 1)%nat STEPN H).
  eapply safe_corestep_backward; eauto.
Qed.

End safety.

Section safety_preservation_lemmas.
Context  {F V TF TV C D Z data : Type}
         {source : CoreSemantics (Genv.t F V) C mem}
         {target : CoreSemantics (Genv.t TF TV) D mem}
         {match_state : data -> meminj -> C -> mem -> D -> mem -> Prop}
         {ord : data -> data -> Prop}
         {geS : Genv.t F V}
         {geT : Genv.t TF TV}
         {entry_points : list (val*val*signature)}

  (sim : Forward_simulation_inject source target geS geT entry_points data match_state ord)
  (c : C)
  (d : D)
  (m : mem)
  (tm: mem)

  (P : val -> mem -> Prop)
  (P_good : forall j v tv m tm, val_inject j v tv -> Mem.inject j m tm -> P v m -> P tv tm)

  (SRC_DET : corestep_fun source)

  (TGT_DET : corestep_fun target)

  (source_safe : forall n, safeN source geS P n c m)
.

Definition my_P := fun (x: data) =>
   forall (j : meminj) (c : C) (d : D) (m tm : mem),
   (forall n : nat, safeN source geS P n c m) ->
   match_state x j c m d tm ->
   (exists rv : val, halted source c = Some rv) \/
   (exists (cd' : data) (j' : meminj) (c' : C) (m' : mem),
      corestep_plus source geS c m c' m' /\
      ((exists (d' : D) (tm' : mem),
          corestep_plus target geT d tm d' tm' /\
          match_state cd' j' c' m' d' tm') \/
       (exists rv : val,
          halted source c' = Some rv /\ match_state cd' j' c' m' d tm))).

Lemma corestep_ord:
  forall cd j,
  match_state cd j c m d tm ->
  (exists rv, halted source c = Some rv) \/
  (exists cd' j' c' m',
      corestep_plus source geS c m c' m'
   /\ ((exists d' tm', corestep_plus target geT d tm d' tm'
                   /\ match_state cd' j' c' m' d' tm')
    \/ (exists rv, halted source c' = Some rv
                   /\ match_state cd' j' c' m' d tm))).
Proof.
destruct sim.
clear match_validblocks0 core_halted0
  core_initial0 core_at_external0 core_after_external0.
intros.
revert j c d m tm source_safe H.
assert (my_well_founded_induction
     : (forall x, (forall y, ord y x -> my_P y) -> my_P x) ->
       forall a, my_P a).
  solve[apply well_founded_induction; auto].
unfold my_P in my_well_founded_induction.
apply my_well_founded_induction; auto.
intros.
case_eq (halted source c).
intros.
solve[left; exists v; auto].
intros HALTED_NONE.
right.
generalize H0 as SAFE; intro.
specialize (H0 (S O)); simpl in H0.
rewrite HALTED_NONE in H0.
destruct H0 as [c2 [m2 [STEP _]]].
generalize STEP as STEP'; intro.
eapply core_diagram0 in STEP; eauto.
destruct STEP as [d2 [tm2 [cd2 [j2 [? [? [? H2]]]]]]].
destruct H2.
exists cd2, j2, c2, m2.
split; auto.
exists O; simpl; exists c2, m2; split; auto.
solve[left; exists d2, tm2; split; auto].
destruct H2 as [H2 ORD].
specialize (H _ ORD j2 c2 d2 m2 tm2).
assert (SAFE': forall n, safeN source geS P n c2 m2).
  solve[intros n; eapply safe_corestep_forward; eauto].
specialize (H SAFE' H4).
destruct H2 as [n H2].
destruct n. inv H2.
destruct H.
destruct H as [rv HALTED].
exists cd2, j2, c2, m2.
split; auto.
solve[exists O; simpl; exists c2, m2; split; auto].
solve[right; exists rv; split; auto].
destruct H as [cd' [j' [c' [m' [STEPN H]]]]].
destruct H as [H|H].
destruct H as [d' [tm' [TSTEP' MATCH']]].
exists cd', j', c', m'.
split; auto.
destruct STEPN as [n STEPN].
exists (S n).
simpl.
exists c2, m2.
split; auto.
solve[left; exists d', tm'; split; auto].
destruct H as [rv [HALT MATCH']].
exists cd', j', c', m'.
split; auto.
destruct STEPN as [n STEPN].
exists (S n).
simpl.
exists c2, m2.
split; auto.
solve[right; exists rv; split; auto].
exists cd2, j2, c2, m2.
split; auto.
solve[exists O; simpl; exists c2, m2; split; auto].
left.
exists d2, tm2.
split; auto.
exists n; auto.
Qed.

Definition halt_match c m d tm :=
  exists rv trv,
    halted source c = Some rv
    /\ halted target d = Some trv
    /\ P rv m
    /\ P trv tm.

Lemma corestep_ord':
  forall cd j,
  match_state cd j c m d tm ->
  halt_match c m d tm
  \/ (exists cd' j' c' m',
         corestep_plus source geS c m c' m'
         /\ ((match_state cd' j' c' m' d tm /\ halt_match c' m' d tm)
            \/ (exists d' tm',
                  corestep_plus target geT d tm d' tm'
                  /\ match_state cd' j' c' m' d' tm'))).
Proof.
intros.
generalize H as MATCH; intro.
apply corestep_ord in H.
destruct H.
{
destruct H as [rv HALT].
left.
unfold halt_match.
destruct sim.
clear match_validblocks0 core_diagram0
  core_initial0 core_at_external0 core_after_external0.
generalize HALT as HALT'; intro.
apply (core_halted0 cd j c m d tm) in HALT; auto.
destruct HALT as [rv' [INJ [HALT INJ2]]].
exists rv, rv'.
split; auto.
split; auto.
specialize (source_safe (S O)).
simpl in source_safe.
rewrite HALT' in source_safe.
split; auto.
eapply P_good; eauto.
}
{
destruct H as [cd' [j' [c' [m' [STEPN ?]]]]].
destruct H as [H|H].
destruct H as [d' [tm' [TSTEPN MATCH']]].
right.
exists cd', j', c', m'.
split; auto.
right.
exists d', tm'.
solve[split; auto].
destruct H as [rv [HALT MATCH']].
right.
exists cd', j', c', m'.
split; auto.
left.
split; auto.
unfold halt_match.
destruct sim.
clear match_validblocks0 core_diagram0
  core_initial0 core_at_external0 core_after_external0.
generalize HALT as HALT'; intro.
apply (core_halted0 cd' j' c' m' d tm) in HALT; auto.
destruct HALT as [rv' [INJ [HALT INJ2]]].
exists rv, rv'.
split; auto.
split; auto.
assert (H: forall n, safeN source geS P n c' m').
  intro n.
  destruct STEPN as [n0 STEPN].
  specialize (source_safe (n + S (S n0))).
  solve[eapply safe_corestepN_forward in source_safe; eauto].
specialize (H (S O)).
simpl in H.
rewrite HALT' in H.
split; auto.
eapply P_good; eauto.
}
Qed.

End safety_preservation_lemmas.

(** ** Termination preservation *)

Section termination_preservation.
Context  {F V TF TV C D Z data : Type}
         {source : CoreSemantics (Genv.t F V) C mem}
         {target : CoreSemantics (Genv.t TF TV) D mem}
         {match_state : data -> meminj -> C -> mem -> D -> mem -> Prop}
         {ord : data -> data -> Prop}
         {geS : Genv.t F V}
         {geT : (Genv.t TF TV)}
         {entry_points : list (val*val*signature)}

  (sim : Forward_simulation_inject source target geS geT entry_points data match_state ord)
  (c : C)
  (d : D)
  (m : mem)
  (tm: mem)

  (P : val -> mem -> Prop)
  (P_good : forall j v tv m tm, val_inject j v tv -> Mem.inject j m tm -> P v m -> P tv tm)

  (SRC_DET : corestep_fun source)

  (TGT_DET : corestep_fun target)

  (source_safe : forall n, safeN source geS P n c m)
.

Lemma termination_preservation:
  forall cd j c' m' rv1,
  match_state cd j c m d tm ->
  corestep_star source geS c m c' m' ->
  halted source c' = Some rv1 ->
  exists d' tm' rv2,
     corestep_star target geT d tm d' tm'
  /\ halted target d' = Some rv2.
Proof.
intros.
destruct H0 as [n H0].
revert cd j c m d tm H H0 source_safe.
induction n; intros.
simpl in H0. symmetry in H0; inv H0.
apply (corestep_ord' sim c d m tm P) in H; auto.
cut (@halt_match F V _ _ C D source target P c m d tm). intro.
unfold halt_match in H0.
destruct H0 as [rv [trv [? [? [? ?]]]]].
exists d, tm, trv.
split; auto.
solve[exists O; simpl; auto].
destruct H; auto.
destruct H as [? [? [? [? [STEP ?]]]]].
destruct STEP as [n STEP].
simpl in STEP.
destruct STEP as [c2 [m2 [STEP ?]]].
apply corestep_not_halted in STEP.
rewrite STEP in H1; congruence.
simpl in H0.
destruct H0 as [c2 [m2 [? ?]]].
destruct sim.
clear match_validblocks0 core_halted0
  core_initial0 core_at_external0 core_after_external0.
generalize H0 as H0'; intro.
eapply core_diagram0 in H0; eauto.
destruct H0 as [d2 [tm2 [cd2 [j2 [? [? [? ?]]]]]]].
assert (SAFE: forall n, safeN source geS P n c2 m2).
  intros n0.
  solve[eapply safe_corestep_forward in H0'; eauto].
specialize (IHn cd2 j2 c2 m2 d2 tm2 H4 H2 SAFE).
destruct IHn as [d' [tm' [trv [? ?]]]].
exists d', tm', trv.
split; auto.
eapply corestep_star_trans; eauto.
destruct H5.
destruct H5 as [n0 H5].
solve[exists (S n0); auto].
destruct H5; auto.
Qed.

End termination_preservation.

Local Open Scope nat_scope.

(** ** Safety & semantics preservation *)

Section safety_preservation.
Variables F V TF TV C D Z data : Type.
Variable source : CoreSemantics (Genv.t F V) C mem.
Variable target : CoreSemantics (Genv.t TF TV) D mem.
Variable match_state : data -> meminj -> C -> mem -> D -> mem -> Prop.
Variable ord : data -> data -> Prop.
Variable geS : Genv.t F V.
Variable geT : (Genv.t TF TV).
Variable entry_points : list (val*val*signature).
Variable (SRC_DET : corestep_fun source).
Variable (TGT_DET : corestep_fun target).

Lemma safety_preservation:
  forall
  (sim : Forward_simulation_inject source target geS geT entry_points data match_state ord)
  (c : C)
  (d : D)
  (m : mem)
  (tm: mem)

  (P : val -> mem -> Prop)
  (P_good : forall j v tv m tm, val_inject j v tv -> Mem.inject j m tm -> P v m -> P tv tm)
  (MATCH : exists (cd: data) (j: meminj), match_state cd j c m d tm)
  (source_safe : forall n, safeN source geS P n c m),

  forall n, safeN target geT P n d tm.
Proof.
intros until n.
destruct MATCH as [cd [j MATCH2]].
revert cd j c m d tm MATCH2 source_safe.
induction n; simpl; auto.
intros.
apply (corestep_ord' sim c d m tm P) in MATCH2; auto.
destruct MATCH2 as [H|H].
destruct H as [rv [rv' [H1 [H2 [H3 H4]]]]].
rewrite H2; auto.
destruct H as [cd' [j' [c' [m' [STEPN [[H1 H2]|H]]]]]].
destruct H2 as [rv [rv' [A1 [A2 [A3 A4]]]]].
rewrite A2; auto.
destruct H as [d' [tm' [TSTEPN MATCH']]].
destruct TSTEPN as [n0 TSTEPN].
cut (halted target d = None). intros ->.
simpl in TSTEPN.
destruct TSTEPN as [d2 [tm2 [TSTEP TSTEPN]]].
exists d2, tm2.
split; auto.
cut (safeN target geT P (n - n0) d' tm'). intro SAFE.
apply (@safe_corestepN_backward _ _ _ _ _ _ _ _ _ _ _ TSTEPN SAFE).
cut (safeN target geT P n d' tm'). intro.
apply safe_downward with (n' := (n - n0)%nat) in H.
apply H. omega.
apply (IHn _ _ _ _ _ _ MATCH').
intros n1.
destruct STEPN as [n2 STEPN].
specialize (source_safe (n1 + S (S n2))).
generalize @safe_corestepN_forward. intro FORW.
solve[apply (FORW _ _ _ _ _ SRC_DET _ _ _ _ _ _ STEPN source_safe)].
simpl in TSTEPN.
destruct TSTEPN as [d2 [tm2 [STEP ?]]].
solve[apply corestep_not_halted in STEP; auto].
Qed.

Lemma halted_safe:
  forall c m c' m' (P: val -> mem -> Prop) rv,
  corestep_star source geS c m c' m' ->
  halted source c = Some rv ->
  P rv m' ->
  (forall n, safeN source geS P n c m).
Proof.
intros.
destruct H as [n0 H].
revert c m H H0.
induction n0.
simpl. intros. inv H.
destruct n; simpl; auto.
rewrite H0; auto.
intros.
simpl in H.
destruct H as [c2 [m2 [? ?]]].
apply corestep_not_halted in H.
rewrite H in H0.
congruence.
Qed.

End safety_preservation.


From mathcomp Require Import ssreflect.
From Coq.Logic Require Export JMeq EqdepFacts.
From Category.Base Require Import Logic Category Functor NatTran.

Set Universe Polymorphism.

Section WideSubcategory.

  Context {C : Category}.

  Variable P : forall (X Y : Obj C), Hom X Y -> Prop.

  Definition WideSubCatCond : Prop :=
    (forall (X : Obj C), P _ _ (\Id X)) /\
    (forall (X Y Z : Obj C) (f : Hom Y Z) (g : Hom X Y), P _ _ f -> P _ _ g -> P _ _ (f \o g)).

  Program Definition WideSubcategory (cond : WideSubCatCond) : Category :=
    {|
      Obj := Obj C;
      Hom := fun X Y => { f : Hom X Y | P _ _ f};
      Hom_Id := fun X => exist _ (\Id X) ((proj1 cond) X);
      Hom_comp := fun X Y Z => fun f g => exist _ (proj1_sig f \o proj1_sig g) ((proj2 cond) _ _ _ _ _ (proj2_sig f) (proj2_sig g))
    |}.
  Next Obligation.
  Proof.
    rewrite /=.
    apply: eq_dep_eq_sig.
    apply: JMeq_eq_dep.
    exact: Hom_assoc.
    exact: p_proof_irrelevance_jmeq.
  Qed.
  Next Obligation.
    rewrite /=.
    apply: eq_dep_eq_sig.
    apply: JMeq_eq_dep.
    exact: Hom_IdL.
    exact: p_proof_irrelevance_jmeq.
  Qed.
  Next Obligation.
    rewrite /=.
    apply: eq_dep_eq_sig.
    apply: JMeq_eq_dep.
    exact: Hom_IdR.
    exact: p_proof_irrelevance_jmeq.
  Qed.

End WideSubcategory.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e256m2e224p2e192p2e96m1_11limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (sub a b) = F.sub (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_sub ().
  Show Ltac Profile.
Time Defined.

Print Assumptions sub.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

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

End FOFProblem.