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.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj14synthconj1 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural), (@eq natural (mult lv0 (plus (Succ lv1) lv2)) (plus (plus (mult lv1 lv0) lv0) (mult lv2 lv0))).
Admitted.
QuickChick conj14synthconj1.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj15synthconj5 : forall  (lv0 : natural) (lv1 : natural), (@eq natural (mult (Succ lv0) (Succ lv1)) (plus (mult lv0 (Succ lv1)) (Succ lv1))).
Admitted.
QuickChick conj15synthconj5.


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.