Require Import Arith List.
Import List.ListNotations.
Require Import Eqdep FunctionalExtensionality Coq.Program.Tactics.
Require Import Coq.Init.Specif.
Require Import Coq.Logic.JMeq.

Require Import TPipStaticM2.
Require Import TRInductM2.
Require Import DetermM2.
(* Require Import Test3. *)

Module Reflect (IdT: IdModType) <: IdModType.
(* Export IdT. *)

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

Module DeterminismC := Determinism IdT.
Export DeterminismC.

Definition MM (S A : Type) : Type := S -> A * S.

Definition ret {S A : Type} (a : A) : MM S A :=
  fun s => (a , s).

Definition bind {S A B : Type} (m : MM S A)(f : A -> MM S B) : MM S B :=
fun s => match m s with
    | (a, s') => f a s'
    end.

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

Definition VTyp_Trans (t: VTyp) : Type :=
  vtypExt t.

Definition PTyp1_Trans (pt: PTyp) : list Type :=
  match pt with
      PT ts => map vtypExt ts
  end.

Fixpoint TList_Trans (ts: list VTyp) : Type :=
  match ts with
      | nil => unit
      | (t::ts') => (VTyp_Trans t) * (TList_Trans ts')
  end.

Definition valTC_Trans (tenv: valTC) : Type := TList_Trans (map snd tenv).

(*
Fixpoint valTC_Trans (tenv: valTC) : Type :=
  match tenv with
      | nil => unit
      | (t::ts) => (VTyp_Trans (snd t)) * (valTC_Trans ts)
  end.
*)

Definition PTyp_Trans (pt: PTyp) : Type :=
  match pt with
      PT ts => TList_Trans ts
  end.

Fixpoint tlist2type (ts: list Type) : Type :=
  match ts with
    | nil => unit
    | (t::ts') => t * tlist2type ts'
  end.

Inductive IsTypeList1 : list Type -> Type :=
  | IsTLN1 : IsTypeList1 nil
  | IsTLC1 : forall (ts: list Type) (t: Type),
              IsTypeList1 ts -> IsTypeList1 (t::ts).

Program Fixpoint listTypTrA (xts: list Type) (ps : tlist2type xts) :
  list Value := _.

Next Obligation.
  dependent induction xts.
  exact nil.
  inversion ps; subst.
  apply IHxts in X0.
  exact (cst a X::X0).
(*  Show Proof. *)
Defined.

Program Fixpoint listTypTrB (xts: list VTyp) (ps : TList_Trans xts) :
  list Value := _.

Next Obligation.
  dependent induction xts.
  exact nil.
  inversion ps; subst.
  apply IHxts in X0.
  exact (cst (VTyp_Trans a) X::X0).
Defined.

Program Fixpoint listTypTr (xts: list VTyp) (ps : TList_Trans xts) :
  list Value := _.

Next Obligation.
  revert ps.
  induction xts.
  intros.
  exact nil.
  intros.
  simple inversion ps; subst.
  intros.
  apply IHxts in X0.
  exact (cst (VTyp_Trans a) X::X0).
Defined.

Lemma listTypTrL1 (t: VTyp) (ts: list VTyp)
                   (v: VTyp_Trans t) (pv: TList_Trans ts) :
  listTypTr (t::ts) (v,pv) = (cst (vtypExt t) v) :: (listTypTr ts pv).

unfold VTyp_Trans in v.
unfold vtypExt in v.
unfold vtypExt.
simpl.
unfold VTyp_Trans.
unfold vtypExt.
simpl.
cut (listTypTr_obligation_1 ts pv = listTypTr ts pv).
intros.
rewrite H.
reflexivity.
revert pv.
induction ts.
intros.
reflexivity.
intros.
simpl.
reflexivity.
Defined.

Inductive IsTypeList : list Type -> list Value -> Type :=
  | IsTLN : IsTypeList nil nil
  | IsTLC : forall (ts: list Type) (vs: list Value) (t: Type) (v: t),
              IsTypeList ts vs -> IsTypeList (t::ts) (cst t v::vs).

Definition valTC2_Trans (tenv: valTC) : list (Id * Type) :=
  map (fun (x: Id * VTyp) => (fst x, VTyp_Trans (snd x))) tenv.

Definition valTC1_Trans (tenv: valTC) : list Type :=
  map (fun (x: Id * VTyp) => (VTyp_Trans (snd x))) tenv.

Fixpoint valTC_TransA (tenv: valTC) : Type :=
  match tenv with
      | nil => unit
      | (t::ts) => (VTyp_Trans (snd t)) * (valTC_TransA ts)
  end.

Definition FTyp_Trans1 (ft: FTyp) : Type :=
  match ft with
    | FT tenv t => valTC_Trans tenv -> MM W (VTyp_Trans t)
  end.

Definition FTyp_Trans (ft: FTyp) : Type :=
   valTC_Trans (extParType ft) -> MM W (VTyp_Trans (extRetType ft)).
Definition funTC2_Trans (tenv: funTC) : list (Id * Type) :=
  map (fun (x: Id * FTyp) => (fst x, FTyp_Trans (snd x))) tenv.

Definition funTC1_Trans (tenv: funTC) : list Type :=
  map (fun (x: Id * FTyp) => (FTyp_Trans (snd x))) tenv.

Fixpoint funTC_Trans (tenv: funTC) : Type :=
  match tenv with
      | nil => unit
      | (t::ts) => (FTyp_Trans (snd t)) * (funTC_Trans ts)
  end.

Definition Value_Trans (v: Value) :  projT1 v := cstExt v.

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

Definition valTyp (v: Value) : Type := projT1 v.

Definition vList_Typ_Trans (ls: list Value) : Type :=
      tlist2type (map valTyp ls).

Program Fixpoint vList_Trans (ls: list Value) : vList_Typ_Trans ls
        (*  tlist2type (map valTyp ls) *)
  := _.
Next Obligation.
  induction ls.
  simpl.
  exact tt.
  simpl.
  split.
  exact (Value_Trans a).
  exact IHls.
Defined.

Definition valEnv_Typ_Trans (env: valEnv) : Type :=
    vList_Typ_Trans (map snd env).

Definition valEnv_Trans (env: valEnv) :
  valEnv_Typ_Trans env := vList_Trans (map snd env).

Lemma WT_Value_Trans (v: Value) (t: VTyp) :
   ValueTyping v t -> valTyp v = VTyp_Trans t.
  intros.
  inversion H; subst.
  unfold valTyp.
  unfold VTyp_Trans.
  unfold vtypExt.
  auto.
Defined.

Lemma WT_valEnv_Trans_eq (tenv: valTC) (env: valEnv) :
  EnvTyping env tenv ->
              valTC_Trans tenv = valEnv_Typ_Trans env.
  intros.
  dependent induction X.
  compute.
  reflexivity.
  assert (valTC_Trans ((k, v2) :: ls2) =
          prod (VTyp_Trans v2) (valTC_Trans ls2)).
  reflexivity.
  assert (valEnv_Typ_Trans ((k, v1) :: ls1) =
          prod (valTyp v1) (valEnv_Typ_Trans ls1)).
  reflexivity.
  rewrite H.
  rewrite H0.
  rewrite IHX.
  eapply WT_Value_Trans in r.
  rewrite r.
  auto.
Defined.

Lemma WT_valEnv_Trans (tenv: valTC) (env: valEnv) :
  EnvTyping env tenv -> valTC_Trans tenv.
intros.
assert (valEnv_Typ_Trans env).
exact (valEnv_Trans env).
rewrite (WT_valEnv_Trans_eq tenv env).
exact X0.
exact X.
Defined.

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

Definition E_Trans0 :=
    fun (ftenv: funTC) (tenv: valTC) (fenv: funEnv)
          (e: Exp) (t: VTyp) (ET: ExpTyping ftenv tenv fenv e t) =>
        MM W (VTyp_Trans t).

Definition F_Trans0 := fun (f: Fun) (ft: FTyp)
               (ET: FunTyping f ft) => FTyp_Trans ft.

Definition Q_Trans0 :=
    fun (ftenv: funTC) (fenv: funEnv) (q: QFun) (ft: FTyp)
                (ET: QFunTyping ftenv fenv q ft) =>
                        FTyp_Trans ft.

Definition P_Trans0 :=
    fun (ftenv: funTC) (tenv: valTC) (fenv: funEnv)
                (ps: Prms) (ts: PTyp)
                (ET: PrmsTyping ftenv tenv fenv ps ts) =>
       MM W (PTyp_Trans ts).

Definition ExpTypingTrans0_rect :=
  ExpTyping_str_rect
           F_Trans0 Q_Trans0 E_Trans0 P_Trans0.

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

Definition E_Trans :=
  fun (ftenv: funTC) (tenv: valTC) (fenv: funEnv)
          (e: Exp) (t: VTyp) (ET: ExpTyping ftenv tenv fenv e t) =>
  FEnvTyping fenv ftenv ->
  forall env: valEnv,
        EnvTyping env tenv ->
        MM W (VTyp_Trans t).

Definition F_Trans :=
  fun (f: Fun) (ft: FTyp)
               (FT: FunTyping f ft) =>
 (* forall env: valEnv,
       EnvTyping env (extParType ft) -> *)
       FTyp_Trans ft.

Definition Q_Trans :=
  fun (ftenv: funTC) (fenv: funEnv) (q: QFun) (ft: FTyp)
                          (QT: QFunTyping ftenv fenv q ft) =>
  FEnvTyping fenv ftenv ->
(*  forall env: valEnv,
       EnvTyping env (extParType ft) ->  *)
       FTyp_Trans ft.

Definition P_Trans :=
  fun (ftenv: funTC) (tenv: valTC) (fenv: funEnv)
                (ps: Prms) (ts: PTyp)
                (ET: PrmsTyping ftenv tenv fenv ps ts) =>
  FEnvTyping fenv ftenv ->
  forall env: valEnv,
        EnvTyping env tenv ->
        MM W (PTyp_Trans ts).

Definition ExpTypingTrans_rect :=
  ExpTyping_str_rect
           F_Trans Q_Trans E_Trans P_Trans.

Definition FunTypingTrans_rect :=
  ExpTypingF_str_rect
           F_Trans Q_Trans E_Trans P_Trans.

Definition ParTypingTrans_rect :=
  ExpTypingP_str_rect
           F_Trans Q_Trans E_Trans P_Trans.

Definition QFunTypingTrans_rect :=
  ExpTypingQ_str_rect
           F_Trans Q_Trans E_Trans P_Trans.

Lemma envTypingListTT (fps : valTC) (t0 : TList_Trans (map snd fps)):
  EnvTyping (mkVEnv fps (listTypTr (map snd fps) t0)) fps.
Proof.
    unfold mkVEnv.
    dependent induction fps.
    constructor.
    destruct a.
    rewrite map_cons.

    assert (listTypTr (map snd ((i, v) :: fps)) t0 =
            listTypTr (snd (i, v) :: (map snd fps)) t0).
    simpl.
    reflexivity.

    rewrite H.

    assert (listTypTr (snd (i, v) :: (map snd fps)) t0 =
            listTypTr (v :: (map snd fps)) t0).
    simpl.
    reflexivity.

    rewrite H0 at 1.

    assert (fst (i,v) = i).
    auto.

    rewrite H1.

    destruct t0.

    rewrite listTypTrL1.

    simpl.
    constructor.
    constructor.
    simpl.
    reflexivity.
    simpl.
    constructor.

    assert (EnvTyping (interleave (map fst fps)
                                  (listTypTr (map snd fps) t)) fps).
    eapply IHfps.
    unfold EnvTyping in X.
    exact X.
Defined.

Program Fixpoint Exp_Trans
        (ftenv: funTC) (tenv: valTC) (fenv: funEnv)
         (e: Exp) (t: VTyp) (ET: ExpTyping ftenv tenv fenv e t) :
  FEnvTyping fenv ftenv ->
  forall env: valEnv,
        EnvTyping env tenv ->
        MM W (VTyp_Trans t) := _
with Fun_Trans
               (f: Fun) (ft: FTyp)
               (ET: FunTyping f ft) :
(*  forall env: valEnv,
       EnvTyping env (extParType ft) ->  *)
       FTyp_Trans ft := _
with QFun_Trans
                (ftenv: funTC) (fenv: funEnv) (q: QFun) (ft: FTyp)
                (ET: QFunTyping ftenv fenv q ft) :
  FEnvTyping fenv ftenv ->
(*  forall env: valEnv,
       EnvTyping env (extParType ft) ->  *)
       FTyp_Trans ft := _
with Prms_Trans
                (ftenv: funTC) (tenv: valTC) (fenv: funEnv)
                (ps: Prms) (ts: PTyp)
                (ET: PrmsTyping ftenv tenv fenv ps ts) :
  FEnvTyping fenv ftenv ->
  forall env: valEnv,
        EnvTyping env tenv ->
        MM W (PTyp_Trans ts) := _.

Next Obligation.

  revert X0.
  revert env.
  revert X.
  revert ET.
  revert e t.
  eapply ExpTypingTrans_rect.

  - (* forall2_nil *)
    unfold Par_SSL.
    intros.
    constructor.
  - (* forall2_cons *)
    unfold Par_SSL.
    intros.
    econstructor.
    exact X0.
    exact X.
  - (* matchenvs_nil *)
    unfold Par_SSA.
    constructor.
  - (* matchenvs_cons *)
    unfold Par_SSA.
    intros.
    econstructor.
    exact X0.
    exact X.
  - (* matchenvs2_split *)
    unfold Par_SSB, Par_SSA.
    intros.
    econstructor.
    exact m0.
    exact m1.
    assumption.
    assumption.
    exact X.
    exact X0.
    exact X1.
  - (* funz *)
    unfold E_Trans, F_Trans.
    unfold FTyp_Trans.
    intros.
    specialize (X m).
    unfold valTC_Trans in X0.
    assert (EnvTyping (mkVEnv tenv0 (listTypTr (map snd tenv0) X0)) tenv0).
    + apply envTypingListTT.
    + apply X in X1.
      exact X1.
  - (* funs *)
    unfold E_Trans, F_Trans.
    intros.
    unfold FTyp_Trans.
    intros.
    assert (FEnvTyping fenv' ftenv').
    + rewrite h1.
      rewrite h2.
      eapply updateFEnvLemma.
      exact m.
      exact k2.
    + specialize (X X2).
      (* unfold FTyp_Trans in X0. *)
      unfold valTC_Trans in X1.
      assert (EnvTyping (mkVEnv tenv0 (listTypTr (map snd tenv0) X1)) tenv0).
      * apply envTypingListTT.
      * apply X in X3.
        exact X3.
  - (* QF *)
    unfold Q_Trans, F_Trans.
    intros.
    exact X.
  - (* FVar *)
    unfold Par_SSB, Q_Trans, F_Trans.
    intros.
    destruct ft.
    inversion X; subst; clear X.
    exact X3.
  - (* modify *)
    unfold E_Trans.
    intros.
    simpl.
    destruct XF.
    unfold MM.
    inversion k; subst.
    + inversion H; subst.
      subst T.
      simpl in H0.
      destruct v.
      destruct v.
      simpl in H0.
      clear k.
      clear H.
      clear H1.
      rewrite H0 in v.
      intros.
      exact (b_eval0 X1 v, b_exec0 X1 v).
    + inversion X1; subst.
      eapply ExRelValT with (x0:=x) (t:=vtyp T1) in X0.
      destruct X0.
      destruct x0.
      destruct v0.
      inversion v; subst.
      subst T.
      simpl in H.
      clear f.
      clear v.
      clear H0.
      rewrite H in v0.
      intros.
      exact (b_eval0 X0 v0, b_exec0 X0 v0).
      exact X2.
  - (* return *)
    unfold E_Trans.
    intros.
    simpl.
    inversion k; subst.
    + inversion H; subst.
      subst T.
      destruct v.
      destruct v.
      simpl in H0.
      unfold VTyp_Trans.
      unfold vtypExt.
      clear k H H1.
      rewrite H0 in v.
      exact (ret v).
    + inversion X1; subst.
      eapply ExRelValT with (x0:=x) (t0:=t) in X0.
      destruct X0.
      destruct x0.
      destruct v0.
      inversion v; subst.
      subst T.
      simpl in H.
      clear f v H0.
      rewrite H in v0.
      exact (ret v0).
      exact X2.
  - (* bindn *)
    unfold E_Trans.
    intros.
    simpl.
    specialize (X X1 env X2).
    specialize (X0 X1 env X2).
    exact (bind X (fun _ => X0)).
  - (* binds *)
    unfold E_Trans.
    intros.
    simpl.
    specialize (X X1 env X2).
    specialize (X0 X1).
    unfold MM.
    intros.
(**)
    unfold MM in X.
    apply X in X3.
    destruct X3.
    eapply (updateVEnvLemma env tenv0 x
                            (cst (VTyp_Trans t1) v) t1) in X2.
    specialize (X0 (updateE env x (cst (VTyp_Trans t1) v))).
    rewrite h in X0.
    apply X0 in X2.
    apply (X2 w).
    unfold VTyp_Trans.
    unfold vtypExt.
    constructor.
    simpl.
    reflexivity.
    constructor.
  - (* bindms *)
    unfold E_Trans.
    intros.
    simpl.
    specialize (overrideFEnvLemma
                                  fenvP fenv0 ftenvP ftenv0 m2 X0).
    intro.
    rewrite h2 in X.
    rewrite h3 in X.
    specialize (X X2).
    specialize (overrideVEnvLemma envP env tenvP tenv0 k1 X1).
    intros.
    rewrite h1 in X.
    apply X in X3.
    exact X3.
  - (* apply *)
    unfold E_Trans, Q_Trans, P_Trans.
    intros.
    specialize (X X1).
    specialize (X0 X1 env X2).
    simpl in X.
    inversion k2; subst.
    unfold env2ptyp in H3.
    inversion H3; subst.
    simpl in X0.
    unfold MM; intros.
    unfold MM in X0.
    specialize (X0 X4); clear X4.
    destruct X0.
    clear H3.
    specialize (X t0).

    unfold MM in X.
    apply (X w).

  - (* val *)
    unfold E_Trans.
    intros.
    simpl.
    unfold VTyp_Trans.
    unfold vtypExt.
    inversion k.
    subst T.
    rewrite <- H.
    exact (ret (cstExt v)).
  - (* ifthenelse *)
    unfold E_Trans.
    intros.
    simpl.
    specialize (X X2 env X3).
    specialize (X0 X2 env X3).
    specialize (X1 X2 env X3).

    unfold MM; intro.
    unfold MM in X.
    specialize (X X4).
    destruct X.
    simpl in v.
    destruct v.
    exact (X0 w).
    exact (X1 w).
  - (* PS *)
    unfold Par_SSL, P_Trans.
    unfold E_Trans.
    intros.
    simpl.
    induction X.
    simpl.
    exact (ret tt).
    simpl.
    specialize (p0 X0 env X1).
    inversion m; subst.
    specialize (IHX X3).
    unfold MM; intro.
    specialize (p0 X4).
    destruct p0.
    specialize (IHX w).
    destruct IHX.
    exact (v, t, w0).
Defined.

Next Obligation.

  revert ET.
  revert f ft.
  eapply FunTypingTrans_rect.

  - (* forall2_nil *)
    unfold Par_SSL.
    intros.
    constructor.
  - (* forall2_cons *)
    unfold Par_SSL.
    intros.
    econstructor.
    exact X0.
    exact X.
  - (* matchenvs_nil *)
    unfold Par_SSA.
    constructor.
  - (* matchenvs_cons *)
    unfold Par_SSA.
    intros.
    econstructor.
    exact X0.
    exact X.
  - (* matchenvs2_split *)
    unfold Par_SSB, Par_SSA.
    intros.
    econstructor.
    exact m0.
    exact m1.
    assumption.
    assumption.
    exact X.
    exact X0.
    exact X1.
  - (* funz *)
    unfold E_Trans, F_Trans.
    unfold FTyp_Trans.
    intros.
    specialize (X m).
    unfold valTC_Trans in X0.
    assert (EnvTyping (mkVEnv tenv (listTypTr (map snd tenv) X0)) tenv).
    + apply envTypingListTT.
    + apply X in X1.
      exact X1.
  - (* funs *)
    unfold E_Trans, F_Trans.
    intros.
    unfold FTyp_Trans.
    intros.
    assert (FEnvTyping fenv' ftenv').
    + rewrite h1.
      rewrite h2.
      eapply updateFEnvLemma.
      exact m.
      exact k2.
    + specialize (X X2).
      (* unfold FTyp_Trans in X0. *)
      unfold valTC_Trans in X1.
      assert (EnvTyping (mkVEnv tenv (listTypTr (map snd tenv) X1)) tenv).
      * apply envTypingListTT.
      * apply X in X3.
        exact X3.
  - (* QF *)
    unfold Q_Trans, F_Trans.
    intros.
    exact X.
  - (* FVar *)
    unfold Par_SSB, Q_Trans, F_Trans.
    intros.
    destruct ft.
    inversion X; subst; clear X.
    exact X3.
  - (* modify *)
    unfold E_Trans.
    intros.
    simpl.
    destruct XF.
    unfold MM.
    inversion k; subst.
    + inversion H; subst.
      subst T.
      simpl in H0.
      destruct v.
      destruct v.
      simpl in H0.
      clear k.
      clear H.
      clear H1.
      rewrite H0 in v.
      intros.
      exact (b_eval0 X1 v, b_exec0 X1 v).
    + inversion X1; subst.
      eapply ExRelValT with (x0:=x) (t:=vtyp T1) in X0.
      destruct X0.
      destruct x0.
      destruct v0.
      inversion v; subst.
      subst T.
      simpl in H.
      clear f.
      clear v.
      clear H0.
      rewrite H in v0.
      intros.
      exact (b_eval0 X0 v0, b_exec0 X0 v0).
      exact X2.
  - (* return *)
    unfold E_Trans.
    intros.
    simpl.
    inversion k; subst.
    + inversion H; subst.
      subst T.
      destruct v.
      destruct v.
      simpl in H0.
      unfold VTyp_Trans.
      unfold vtypExt.
      clear k H H1.
      rewrite H0 in v.
      exact (ret v).
    + inversion X1; subst.
      eapply ExRelValT with (x0:=x) (t0:=t) in X0.
      destruct X0.
      destruct x0.
      destruct v0.
      inversion v; subst.
      subst T.
      simpl in H.
      clear f v H0.
      rewrite H in v0.
      exact (ret v0).
      exact X2.
  - (* bindn *)
    unfold E_Trans.
    intros.
    simpl.
    specialize (X X1 env X2).
    specialize (X0 X1 env X2).
    exact (bind X (fun _ => X0)).
  - (* binds *)
    unfold E_Trans.
    intros.
    simpl.
    specialize (X X1 env X2).
    specialize (X0 X1).
    unfold MM.
    intros.
(**)
    unfold MM in X.
    apply X in X3.
    destruct X3.
    eapply (updateVEnvLemma env tenv x
                            (cst (VTyp_Trans t1) v) t1) in X2.
    specialize (X0 (updateE env x (cst (VTyp_Trans t1) v))).
    rewrite h in X0.
    apply X0 in X2.
    apply (X2 w).
    unfold VTyp_Trans.
    unfold vtypExt.
    constructor.
    simpl.
    reflexivity.
    constructor.
  - (* bindms *)
    unfold E_Trans.
    intros.
    simpl.
    specialize (overrideFEnvLemma
                                  fenvP fenv ftenvP ftenv m2 X0).
    intro.
    rewrite h2 in X.
    rewrite h3 in X.
    specialize (X X2).
    specialize (overrideVEnvLemma envP env tenvP tenv k1 X1).
    intros.
    rewrite h1 in X.
    apply X in X3.
    exact X3.
  - (* apply *)
    unfold E_Trans, Q_Trans, P_Trans.
    intros.
    specialize (X X1).
    specialize (X0 X1 env X2).
    simpl in X.
    inversion k2; subst.
    unfold env2ptyp in H3.
    inversion H3; subst.
    simpl in X0.
    unfold MM; intros.
    unfold MM in X0.
    specialize (X0 X4); clear X4.
    destruct X0.
    clear H3.
    specialize (X t0).

    unfold MM in X.
    apply (X w).

  - (* val *)
    unfold E_Trans.
    intros.
    simpl.
    unfold VTyp_Trans.
    unfold vtypExt.
    inversion k.
    subst T.
    rewrite <- H.
    exact (ret (cstExt v)).
  - (* ifthenelse *)
    unfold E_Trans.
    intros.
    simpl.
    specialize (X X2 env X3).
    specialize (X0 X2 env X3).
    specialize (X1 X2 env X3).

    unfold MM; intro.
    unfold MM in X.
    specialize (X X4).
    destruct X.
    simpl in v.
    destruct v.
    exact (X0 w).
    exact (X1 w).
  - unfold Par_SSL, P_Trans.
    unfold E_Trans.
    intros.
    simpl.
    induction X.
    simpl.
    exact (ret tt).
    simpl.
    specialize (p0 X0 env X1).
    inversion m; subst.
    specialize (IHX X3).
    unfold MM; intro.
    specialize (p0 X4).
    destruct p0.
    specialize (IHX w).
    destruct IHX.
    exact (v, t, w0).
Defined.

Next Obligation.

  revert X0.
  revert env.
  revert X.
  revert ET.
  revert ps ts.
  eapply ParTypingTrans_rect.

  - (* forall2_nil *)
    unfold Par_SSL.
    intros.
    constructor.
  - (* forall2_cons *)
    unfold Par_SSL.
    intros.
    econstructor.
    exact X0.
    exact X.
  - (* matchenvs_nil *)
    unfold Par_SSA.
    constructor.
  - (* matchenvs_cons *)
    unfold Par_SSA.
    intros.
    econstructor.
    exact X0.
    exact X.
  - (* matchenvs2_split *)
    unfold Par_SSB, Par_SSA.
    intros.
    econstructor.
    exact m0.
    exact m1.
    assumption.
    assumption.
    exact X.
    exact X0.
    exact X1.
  - (* funz *)
    unfold E_Trans, F_Trans.
    unfold FTyp_Trans.
    intros.
    specialize (X m).
    unfold valTC_Trans in X0.
    assert (EnvTyping (mkVEnv tenv0 (listTypTr (map snd tenv0) X0)) tenv0).
    + apply envTypingListTT.
    + apply X in X1.
      exact X1.
  - (* funs *)
    unfold E_Trans, F_Trans.
    intros.
    unfold FTyp_Trans.
    intros.
    assert (FEnvTyping fenv' ftenv').
    + rewrite h1.
      rewrite h2.
      eapply updateFEnvLemma.
      exact m.
      exact k2.
    + specialize (X X2).
      (* unfold FTyp_Trans in X0. *)
      unfold valTC_Trans in X1.
      assert (EnvTyping (mkVEnv tenv0 (listTypTr (map snd tenv0) X1)) tenv0).
      * apply envTypingListTT.
      * apply X in X3.
        exact X3.
  - (* QF *)
    unfold Q_Trans, F_Trans.
    intros.
    exact X.
  - (* FVar *)
    unfold Par_SSB, Q_Trans, F_Trans.
    intros.
    destruct ft.
    inversion X; subst; clear X.
    exact X3.
  - (* modify *)
    unfold E_Trans.
    intros.
    simpl.
    destruct XF.
    unfold MM.
    inversion k; subst.
    + inversion H; subst.
      subst T.
      simpl in H0.
      destruct v.
      destruct v.
      simpl in H0.
      clear k.
      clear H.
      clear H1.
      rewrite H0 in v.
      intros.
      exact (b_eval0 X1 v, b_exec0 X1 v).
    + inversion X1; subst.
      eapply ExRelValT with (x0:=x) (t:=vtyp T1) in X0.
      destruct X0.
      destruct x0.
      destruct v0.
      inversion v; subst.
      subst T.
      simpl in H.
      clear f.
      clear v.
      clear H0.
      rewrite H in v0.
      intros.
      exact (b_eval0 X0 v0, b_exec0 X0 v0).
      exact X2.
  - (* return *)
    unfold E_Trans.
    intros.
    simpl.
    inversion k; subst.
    + inversion H; subst.
      subst T.
      destruct v.
      destruct v.
      simpl in H0.
      unfold VTyp_Trans.
      unfold vtypExt.
      clear k H H1.
      rewrite H0 in v.
      exact (ret v).
    + inversion X1; subst.
      eapply ExRelValT with (x0:=x) (t0:=t) in X0.
      destruct X0.
      destruct x0.
      destruct v0.
      inversion v; subst.
      subst T.
      simpl in H.
      clear f v H0.
      rewrite H in v0.
      exact (ret v0).
      exact X2.
  - (* bindn *)
    unfold E_Trans.
    intros.
    simpl.
    specialize (X X1 env X2).
    specialize (X0 X1 env X2).
    exact (bind X (fun _ => X0)).
  - (* binds *)
    unfold E_Trans.
    intros.
    simpl.
    specialize (X X1 env X2).
    specialize (X0 X1).
    unfold MM.
    intros.
(**)
    unfold MM in X.
    apply X in X3.
    destruct X3.
    eapply (updateVEnvLemma env tenv0 x
                            (cst (VTyp_Trans t1) v) t1) in X2.
    specialize (X0 (updateE env x (cst (VTyp_Trans t1) v))).
    rewrite h in X0.
    apply X0 in X2.
    apply (X2 w).
    unfold VTyp_Trans.
    unfold vtypExt.
    constructor.
    simpl.
    reflexivity.
    constructor.
  - (* bindms *)
    unfold E_Trans.
    intros.
    simpl.
    specialize (overrideFEnvLemma
                                  fenvP fenv0 ftenvP ftenv0 m2 X0).
    intro.
    rewrite h2 in X.
    rewrite h3 in X.
    specialize (X X2).
    specialize (overrideVEnvLemma envP env tenvP tenv0 k1 X1).
    intros.
    rewrite h1 in X.
    apply X in X3.
    exact X3.
  - (* apply *)
    unfold E_Trans, Q_Trans, P_Trans.
    intros.
    specialize (X X1).
    specialize (X0 X1 env X2).
    simpl in X.
    inversion k2; subst.
    unfold env2ptyp in H3.
    inversion H3; subst.
    simpl in X0.
    unfold MM; intros.
    unfold MM in X0.
    specialize (X0 X4); clear X4.
    destruct X0.
    clear H3.
    specialize (X t0).

    unfold MM in X.
    apply (X w).

  - (* val *)
    unfold E_Trans.
    intros.
    simpl.
    unfold VTyp_Trans.
    unfold vtypExt.
    inversion k.
    subst T.
    rewrite <- H.
    exact (ret (cstExt v)).
  - (* ifthenelse *)
    unfold E_Trans.
    intros.
    simpl.
    specialize (X X2 env X3).
    specialize (X0 X2 env X3).
    specialize (X1 X2 env X3).

    unfold MM; intro.
    unfold MM in X.
    specialize (X X4).
    destruct X.
    simpl in v.
    destruct v.
    exact (X0 w).
    exact (X1 w).
  - unfold Par_SSL, P_Trans.
    unfold E_Trans.
    intros.
    simpl.
    induction X.
    simpl.
    exact (ret tt).
    simpl.
    specialize (p0 X0 env X1).
    inversion m; subst.
    specialize (IHX X3).
    unfold MM; intro.
    specialize (p0 X4).
    destruct p0.
    specialize (IHX w).
    destruct IHX.
    exact (v, t, w0).
Defined.

Next Obligation.

  revert X.
  revert ET.
  revert q ft.
  eapply QFunTypingTrans_rect.

  - (* forall2_nil *)
    unfold Par_SSL.
    intros.
    constructor.
  - (* forall2_cons *)
    unfold Par_SSL.
    intros.
    econstructor.
    exact X0.
    exact X.
  - (* matchenvs_nil *)
    unfold Par_SSA.
    constructor.
  - (* matchenvs_cons *)
    unfold Par_SSA.
    intros.
    econstructor.
    exact X0.
    exact X.
  - (* matchenvs2_split *)
    unfold Par_SSB, Par_SSA.
    intros.
    econstructor.
    exact m0.
    exact m1.
    assumption.
    assumption.
    exact X.
    exact X0.
    exact X1.
  - (* funz *)
    unfold E_Trans, F_Trans.
    unfold FTyp_Trans.
    intros.
    specialize (X m).
    unfold valTC_Trans in X0.
    assert (EnvTyping (mkVEnv tenv (listTypTr (map snd tenv) X0)) tenv).
    + apply envTypingListTT.
    + apply X in X1.
      exact X1.
  - (* funs *)
    unfold E_Trans, F_Trans.
    intros.
    unfold FTyp_Trans.
    intros.
    assert (FEnvTyping fenv' ftenv').
    + rewrite h1.
      rewrite h2.
      eapply updateFEnvLemma.
      exact m.
      exact k2.
    + specialize (X X2).
      (* unfold FTyp_Trans in X0. *)
      unfold valTC_Trans in X1.
      assert (EnvTyping (mkVEnv tenv (listTypTr (map snd tenv) X1)) tenv).
      * apply envTypingListTT.
      * apply X in X3.
        exact X3.
  - (* QF *)
    unfold Q_Trans, F_Trans.
    intros.
    exact X.
  - (* FVar *)
    unfold Par_SSB, Q_Trans, F_Trans.
    intros.
    destruct ft.
    inversion X; subst; clear X.
    exact X3.
  - (* modify *)
    unfold E_Trans.
    intros.
    simpl.
    destruct XF.
    unfold MM.
    inversion k; subst.
    + inversion H; subst.
      subst T.
      simpl in H0.
      destruct v.
      destruct v.
      simpl in H0.
      clear k.
      clear H.
      clear H1.
      rewrite H0 in v.
      intros.
      exact (b_eval0 X1 v, b_exec0 X1 v).
    + inversion X1; subst.
      eapply ExRelValT with (x0:=x) (t:=vtyp T1) in X0.
      destruct X0.
      destruct x0.
      destruct v0.
      inversion v; subst.
      subst T.
      simpl in H.
      clear f.
      clear v.
      clear H0.
      rewrite H in v0.
      intros.
      exact (b_eval0 X0 v0, b_exec0 X0 v0).
      exact X2.
  - (* return *)
    unfold E_Trans.
    intros.
    simpl.
    inversion k; subst.
    + inversion H; subst.
      subst T.
      destruct v.
      destruct v.
      simpl in H0.
      unfold VTyp_Trans.
      unfold vtypExt.
      clear k H H1.
      rewrite H0 in v.
      exact (ret v).
    + inversion X1; subst.
      eapply ExRelValT with (x0:=x) (t0:=t) in X0.
      destruct X0.
      destruct x0.
      destruct v0.
      inversion v; subst.
      subst T.
      simpl in H.
      clear f v H0.
      rewrite H in v0.
      exact (ret v0).
      exact X2.
  - (* bindn *)
    unfold E_Trans.
    intros.
    simpl.
    specialize (X X1 env X2).
    specialize (X0 X1 env X2).
    exact (bind X (fun _ => X0)).
  - (* binds *)
    unfold E_Trans.
    intros.
    simpl.
    specialize (X X1 env X2).
    specialize (X0 X1).
    unfold MM.
    intros.
(**)
    unfold MM in X.
    apply X in X3.
    destruct X3.
    eapply (updateVEnvLemma env tenv x
                            (cst (VTyp_Trans t1) v) t1) in X2.
    specialize (X0 (updateE env x (cst (VTyp_Trans t1) v))).
    rewrite h in X0.
    apply X0 in X2.
    apply (X2 w).
    unfold VTyp_Trans.
    unfold vtypExt.
    constructor.
    simpl.
    reflexivity.
    constructor.
  - (* bindms *)
    unfold E_Trans.
    intros.
    simpl.
    specialize (overrideFEnvLemma
                                  fenvP fenv0 ftenvP ftenv0 m2 X0).
    intro.
    rewrite h2 in X.
    rewrite h3 in X.
    specialize (X X2).
    specialize (overrideVEnvLemma envP env tenvP tenv k1 X1).
    intros.
    rewrite h1 in X.
    apply X in X3.
    exact X3.
  - (* apply *)
    unfold E_Trans, Q_Trans, P_Trans.
    intros.
    specialize (X X1).
    specialize (X0 X1 env X2).
    simpl in X.
    inversion k2; subst.
    unfold env2ptyp in H3.
    inversion H3; subst.
    simpl in X0.
    unfold MM; intros.
    unfold MM in X0.
    specialize (X0 X4); clear X4.
    destruct X0.
    clear H3.
    specialize (X t0).

    unfold MM in X.
    apply (X w).

  - (* val *)
    unfold E_Trans.
    intros.
    simpl.
    unfold VTyp_Trans.
    unfold vtypExt.
    inversion k.
    subst T.
    rewrite <- H.
    exact (ret (cstExt v)).
  - (* ifthenelse *)
    unfold E_Trans.
    intros.
    simpl.
    specialize (X X2 env X3).
    specialize (X0 X2 env X3).
    specialize (X1 X2 env X3).

    unfold MM; intro.
    unfold MM in X.
    specialize (X X4).
    destruct X.
    simpl in v.
    destruct v.
    exact (X0 w).
    exact (X1 w).
  - unfold Par_SSL, P_Trans.
    unfold E_Trans.
    intros.
    simpl.
    induction X.
    simpl.
    exact (ret tt).
    simpl.
    specialize (p0 X0 env X1).
    inversion m; subst.
    specialize (IHX X3).
    unfold MM; intro.
    specialize (p0 X4).
    destruct p0.
    specialize (IHX w).
    destruct IHX.
    exact (v, t, w0).
Defined.

End Reflect.


Require Import VST.floyd.proofauto.
Require Import VST.progs.append.

Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.
Definition t_struct_list := Tstruct _list noattr.

Fixpoint listrep (sh: share)
            (contents: list val) (x: val) : mpred :=
 match contents with
 | h::hs =>
              EX y:val,
                data_at sh t_struct_list (h,y) x * listrep sh hs y
 | nil => !! (x = nullval) && emp
 end.

Arguments listrep sh contents x : simpl never.

Lemma listrep_local_facts:
  forall sh contents p,
     listrep sh contents p |--
     !! (is_pointer_or_null p /\ (p=nullval <-> contents=nil)).
Proof.
intros.
revert p; induction contents;
  unfold listrep; fold listrep; intros. entailer!. intuition.
Intros y. entailer!.
split; intro. subst p. destruct H; contradiction. inv H2.
Qed.

#[export] Hint Resolve listrep_local_facts : saturate_local.

Lemma listrep_valid_pointer:
  forall sh contents p,
   sepalg.nonidentity sh ->
   listrep sh contents p |-- valid_pointer p.
Proof.
 destruct contents; unfold listrep; fold listrep; intros; Intros; subst.
 auto with valid_pointer.
 Intros y.
 apply sepcon_valid_pointer1.
 apply data_at_valid_ptr; auto.
 simpl;  computable.
Qed.

#[export] Hint Resolve listrep_valid_pointer : valid_pointer.

Lemma listrep_null: forall sh contents,
    listrep sh contents nullval = !! (contents=nil) && emp.
Proof.
destruct contents; unfold listrep; fold listrep.
autorewrite with norm. auto.
apply pred_ext.
Intros y. entailer. destruct H; contradiction.
Intros. discriminate.
Qed.

Lemma is_pointer_or_null_not_null:
 forall x, is_pointer_or_null x -> x <> nullval -> isptr x.
Proof.
intros.
 destruct x; try contradiction. hnf in H; subst i. contradiction H0; reflexivity.
 apply I.
Qed.

Definition append_spec :=
 DECLARE _append
  WITH sh : share, x: val, y: val, s1: list val, s2: list val
  PRE [ tptr t_struct_list , tptr t_struct_list]
     PROP(writable_share sh)
     PARAMS (x; y) GLOBALS()
     SEP (listrep sh s1 x; listrep sh s2 y)
  POST [ tptr t_struct_list ]
    EX r: val,
     PROP()
     RETURN (r)
     SEP (listrep sh (s1++s2) r).

Definition Gprog : funspecs :=   ltac:(with_library prog [ append_spec ]).

Module Proof1.

Definition lseg (sh: share) (contents: list val) (x z: val) : mpred :=
  ALL cts2:list val, listrep sh cts2 z -* listrep sh (contents++cts2) x.

Lemma body_append: semax_body Vprog Gprog f_append append_spec.
Proof.
start_function.
forward_if.
*
 subst x. rewrite listrep_null.  Intros.  subst.
 forward.
 Exists y.
 entailer!.
 simpl; auto.
*
 forward.
 destruct s1 as [ | v s1']; unfold listrep at 1; fold listrep.
 Intros.  contradiction.
 Intros u.
 remember (v::s1') as s1.
 forward.
 forward_while
      ( EX a: val, EX s1b: list val, EX t: val, EX u: val,
            PROP ()
            LOCAL (temp _x x; temp _t t; temp _u u; temp _y y)
            SEP (listrep sh (a::s1b++s2) t -* listrep sh (s1++s2) x;
                   data_at sh t_struct_list (a,u) t;
                   listrep sh s1b u;
                   listrep sh s2 y))%assert.
+ (* current assertion implies loop invariant *)
   Exists v s1' x u.
   subst s1. entailer!. simpl. cancel_wand.
+ (* loop test is safe to execute *)
   entailer!.
+ (* loop body preserves invariant *)
   clear v Heqs1.
   destruct s1b; unfold listrep at 3; fold listrep. Intros. contradiction.
   Intros z.
   forward.
   forward.
   Exists (v,s1b,u0,z). unfold fst, snd.
   simpl app.
   entailer!.
   rewrite sepcon_comm.
   apply RAMIF_PLAIN.trans''.
   apply wand_sepcon_adjoint.
   forget (v::s1b++s2) as s3.
   unfold listrep; fold listrep; Exists u0; auto.
+ (* after the loop *)
   clear v s1' Heqs1.
   forward.
   forward.
   rewrite (proj1 H2 (eq_refl _)).
   Exists x.
   simpl app.
   clear.
   entailer!.
   unfold listrep at 3; fold listrep. Intros.
   pull_right (listrep sh (a :: s2) t -* listrep sh (s1 ++ s2) x).
   apply modus_ponens_wand'.
   unfold listrep at 2; fold listrep. Exists y; cancel.
Qed.

End Proof1.

Module Proof2.

Definition lseg (sh: share) (contents: list val) (x z: val) : mpred :=
  ALL cts2:list val, listrep sh cts2 z -* listrep sh (contents++cts2) x.

Lemma body_append: semax_body Vprog Gprog f_append append_spec.
Proof.
start_function.
forward_if.
*
 subst x. rewrite listrep_null. Intros; subst.
 forward.
 Exists y.
 entailer!.
 simpl; auto.
*
 forward.
 destruct s1 as [ | v s1']; unfold listrep; fold listrep. Intros; contradiction.
 Intros u.
 remember (v::s1') as s1.
 forward.
 forward_while
      (EX s1a: list val,  EX a: val, EX s1b: list val, EX t: val, EX u: val,
            PROP (s1 = s1a ++ a :: s1b)
            LOCAL (temp _x x; temp _t t; temp _u u; temp _y y)
            SEP (lseg sh s1a x t;
                   data_at sh t_struct_list (a,u) t;
                   listrep sh s1b u;
                   listrep sh s2 y))%assert.
+ (* current assertion implies loop invariant *)
   Exists (@nil val) v s1' x u.  entailer!.
   unfold lseg. apply allp_right; intro. simpl. cancel_wand.
+ (* loop test is safe to execute *)
   entailer!.
+ (* loop body preserves invariant *)
   clear v Heqs1. subst s1.
   destruct s1b; unfold listrep; fold listrep. Intros; contradiction.
   Intros z.
   forward.
   forward.
   Exists (s1a++[a],v,s1b,u0,z). unfold fst, snd.
   rewrite !app_ass. simpl app.
   entailer!.
   unfold lseg.
   rewrite sepcon_comm.
   clear.
   apply RAMIF_Q.trans'' with (cons a).
   extensionality cts; simpl; rewrite app_ass; reflexivity.
   apply allp_right; intro. apply wand_sepcon_adjoint.
   unfold listrep at 2; fold listrep; Exists u0.  apply derives_refl.
 + (* after the loop *)
   forward. forward.
   Exists x. entailer!.
   destruct H3 as [? _]. specialize (H3 (eq_refl _)). subst s1b.
   unfold listrep at 1.  Intros. autorewrite with norm.  rewrite H0. rewrite app_ass. simpl app.
   unfold lseg.
   rewrite sepcon_assoc.
   eapply derives_trans; [apply allp_sepcon1 | ]. apply allp_left with (a::s2).
   rewrite sepcon_comm.
   eapply derives_trans; [ | apply modus_ponens_wand].
   apply sepcon_derives; [ | apply derives_refl].
   unfold listrep at 2; fold listrep. Exists y; auto.
Qed.

End Proof2.

Module Proof3.  (*************** inductive lseg *******************)

Fixpoint lseg (sh: share)
            (contents: list val) (x z: val) : mpred :=
 match contents with
 | h::hs => !! (x<>z) &&
              EX y:val,
                data_at sh t_struct_list (h,y) x * lseg sh hs y z
 | nil => !! (x = z /\ is_pointer_or_null x) && emp
 end.

Arguments lseg sh contents x z : simpl never.

Lemma lseg_local_facts:
  forall sh contents p q,
     lseg sh contents p q |--
     !! (is_pointer_or_null p /\ is_pointer_or_null q /\ (p=q <-> contents=nil)).
Proof.
intros.
apply derives_trans with (lseg sh contents p q && !! (is_pointer_or_null p /\
        is_pointer_or_null q /\ (p = q <-> contents = []))).
2: entailer!.
revert p; induction contents; intros; simpl; unfold lseg; fold lseg.
entailer!.
intuition.
Intros y. Exists y.
eapply derives_trans.
apply sepcon_derives.
apply derives_refl.
apply IHcontents.
entailer!.
intuition congruence.
Qed.

#[export] Hint Resolve lseg_local_facts : saturate_local.

Lemma lseg_valid_pointer:
  forall sh contents p ,
   sepalg.nonidentity sh ->
   lseg sh contents p nullval |-- valid_pointer p.
Proof.
 destruct contents; unfold lseg; fold lseg; intros. entailer!.
 Intros. Intros y.
 auto with valid_pointer.
Qed.

#[export] Hint Resolve lseg_valid_pointer : valid_pointer.

Lemma lseg_eq: forall sh contents x,
    lseg sh contents x x = !! (contents=nil /\ is_pointer_or_null x) && emp.
Proof.
intros.
destruct contents; unfold lseg; fold lseg.
f_equal. f_equal. f_equal. apply prop_ext; intuition.
apply pred_ext.
Intros y. contradiction.
Intros. discriminate.
Qed.

Lemma lseg_null: forall sh contents,
    lseg sh contents nullval nullval = !! (contents=nil) && emp.
Proof.
intros.
 rewrite lseg_eq.
 apply pred_ext.
 entailer!.
 entailer!.
Qed.

Lemma lseg_cons: forall sh (v u x: val) s,
   readable_share sh ->
 data_at sh t_struct_list (v, u) x * lseg sh s u nullval
 |-- lseg sh [v] x u * lseg sh s u nullval.
Proof.
intros.
     unfold lseg at 2. Exists u.
     entailer.
     destruct s; unfold lseg at 1; fold lseg; entailer.
Qed.

Lemma lseg_cons': forall sh (v u x a b: val) ,
   readable_share sh ->
 data_at sh t_struct_list (v, u) x * data_at sh t_struct_list (a,b) u
 |-- lseg sh [v] x u * data_at sh t_struct_list (a,b) u.
Proof.
intros.
     unfold lseg. Exists u.
     entailer.
Qed.

Lemma lseg_app': forall sh s1 s2 (a w x y z: val),
   readable_share sh ->
   lseg sh s1 w x * lseg sh s2 x y * data_at sh t_struct_list (a,z) y |--
   lseg sh (s1++s2) w y * data_at sh t_struct_list (a,z) y.
Proof.
 intros.
 revert w; induction s1; intro; simpl.
 unfold lseg at 1. entailer!.
 unfold lseg at 1 3; fold lseg. Intros j; Exists j.
 entailer.
 sep_apply (IHs1 j).
 cancel.
Qed.

Lemma lseg_app_null: forall sh s1 s2 (w x: val),
   readable_share sh ->
   lseg sh s1 w x * lseg sh s2 x nullval |--
   lseg sh (s1++s2) w nullval.
Proof.
 intros.
 revert w; induction s1; intro; simpl.
 unfold lseg at 1. entailer!.
 unfold lseg at 1 3; fold lseg. Intros j; Exists j.
 entailer.
 sep_apply (IHs1 j).
 cancel.
Qed.

Lemma lseg_app: forall sh s1 s2 a s3 (w x y z: val),
   readable_share sh ->
   lseg sh s1 w x * lseg sh s2 x y * lseg sh (a::s3) y z |--
   lseg sh (s1++s2) w y * lseg sh (a::s3) y z.
Proof.
 intros.
 unfold lseg at 3 5; fold lseg.
 Intros u; Exists u. rewrite prop_true_andp by auto.
 sep_apply (lseg_app' sh s1 s2 a w x y u); auto.
 cancel.
Qed.

Lemma listrep_lseg_null :
 listrep = fun sh s p => lseg sh s p nullval.
Proof.
extensionality sh s p.
revert p.
induction s; intros.
unfold lseg, listrep; apply pred_ext; entailer!.
unfold lseg, listrep; fold lseg; fold listrep.
apply pred_ext; Intros y; Exists y; rewrite IHs; entailer!.
Qed.

Lemma body_append: semax_body Vprog Gprog f_append append_spec.
Proof.
start_function.
revert POSTCONDITION; rewrite listrep_lseg_null; intro.
forward_if.
*
 subst x. rewrite lseg_null. Intros. subst.
 forward.
 Exists y.
 entailer!.
 simpl; auto.
*
 forward.
 destruct s1 as [ | v s1']; unfold lseg at 1; fold lseg.
 Intros. contradiction H.
 Intros u.
 clear - SH.
 remember (v::s1') as s1.
 forward.
 forward_while
      (EX s1a: list val, EX a: val, EX s1b: list val, EX t: val, EX u: val,
            PROP (s1 = s1a ++ a :: s1b)
            LOCAL (temp _x x; temp _t t; temp _u u; temp _y y)
            SEP (lseg sh s1a x t;
                   data_at sh t_struct_list (a,u) t;
                   lseg sh s1b u nullval;
                   lseg sh s2 y nullval))%assert.
 + (* current assertion implies loop invariant *)
     Exists (@nil val) v s1' x u.
     subst s1. rewrite lseg_eq.
     entailer.
(*     sep_apply (lseg_cons sh v u x s1'); auto. *)
 + (* loop test is safe to execute *)
     entailer!.
 + (* loop body preserves invariant *)
    destruct s1b; unfold lseg at 2; fold lseg.
    Intros. contradiction.
    Intros z.
    forward.
    forward.
    Exists (s1a++a::nil, v0, s1b,u0,z). unfold fst, snd.
    simpl app; rewrite app_ass.
    entailer.
    sep_apply (lseg_cons' sh a u0 t v0 z); auto.
    sep_apply (lseg_app' sh s1a [a] v0 x t u0 z); auto.
    cancel.
 + (* after the loop *)
    clear v s1' Heqs1.
    subst. rewrite lseg_eq. Intros. subst.
    forward.
    forward.
    Exists x.
    entailer!.
    sep_apply (lseg_cons sh a y t s2); auto.
    sep_apply (lseg_app_null sh [a] s2 t y); auto.
    rewrite app_ass.
    sep_apply (lseg_app_null sh s1a ([a]++s2) x t); auto.
Qed.

End Proof3.


(* ************************************************************************** *)
(*                                                                            *)
(* Verified Flash Translation Layer                                           *)
(*                                                                            *)
(*                                                                            *)
(*   Author: Yu Guo <guoyu@ustc.edu.cn>                                       *)
(*                          School of Computer Science and Technology, USTC   *)
(*                                                                            *)
(*           Hui Zhang <sa512073@mail.ustc.edu.cn>                            *)
(*                                     School of Software Engineering, USTC   *)
(*                                                                            *)
(* ************************************************************************** *)

Require Import LibEx.
Require Import ListEx.
Require Import Data.
Require Import Monad.

Require Import Params.
Require Import Nand.

(*  -------------------------------------------------------------

  Lemmas

*)

Lemma page_off_eq_dec :
  forall (loc loc' : page_off),
    loc = loc' \/ loc <> loc'.
Proof.
  intros.
  destruct (nat_eq_dec loc loc').
  left.
  subst;  trivial.
  right.
  intro HF; subst; trivial.
  apply n.
  trivial.
Qed.

Lemma pbn_eq_dec :
  forall (pbn pbn' : block_no),
    pbn = pbn' \/ pbn <> pbn'.
Proof.
  intros.
  destruct (nat_eq_dec pbn pbn').
  left.
  subst;  trivial.
  right.
  intro HF; subst; trivial.
  apply n.
  trivial.
Qed.

Lemma block_no_eq_dec :
  forall pbn pbn' : block_no, pbn = pbn' \/ pbn <> pbn'.
Proof.
  intros.
  destruct (nat_eq_dec pbn pbn'); auto.
Qed.

Lemma nand_erase_block_spec:
  forall c pbn b,
    bvalid_block_no pbn = true
    -> chip_get_block c pbn = Some b
    -> block_state b = bs_programmed
    -> exists c', nand_erase_block c pbn = Some c'
                  /\ chip_set_block c pbn (erased_block (block_erase_count b)) = Some c'
                  /\ chip_get_block c' pbn = Some (erased_block (block_erase_count b))
                  /\ (forall pbn', pbn <> pbn'
                                   -> chip_get_block c pbn' = chip_get_block c' pbn').
Proof.
  intros c pbn b.
  intros Hvb Hc Hbs.
  unfold chip_get_block in Hc.
  unfold nand_erase_block.
  rewrite Hvb.
  unfold chip_get_block.
  rewrite Hc.
  unfold chip_set_block.
  rewrite Hvb.
  destruct (list_get_list_set (l:=(chip_blocks c)) (erased_block (block_erase_count b)) Hc) as [l' Hset].
  rewrite Hset.
  exists (mkchip l').
  split; trivial.
  split; trivial.
  split.
    simpl.
    apply (list_get_list_set_eq Hset); auto.
  intros pbn' Hneq.
  simpl.
  rewrite (list_get_list_set_neq Hset Hneq).
  trivial.
Qed.

Lemma chip_set_block_elim :
  forall c pbn b c' ,
    chip_set_block c pbn b = Some c'
    -> bvalid_block_no pbn = true
       /\ chip_get_block c' pbn = Some b
       /\ forall pbn',
            pbn <> pbn'
            -> chip_get_block c' pbn' = chip_get_block c pbn'.
Proof.
  intros c pbn b c' Hsetc.
  split.
    unfold chip_set_block in Hsetc.
    destruct (bvalid_block_no pbn) eqn: Hvb; try discriminate.
    trivial.
  split.
    unfold chip_get_block.
    unfold chip_set_block in Hsetc.
    destruct (bvalid_block_no pbn) eqn: Hvb; try discriminate.
    destruct (list_set (chip_blocks c) pbn b) eqn: Hset; try discriminate.
    injection Hsetc.
    intro; subst c'.
    simpl.
    rewrite (list_get_list_set_eq Hset).
    trivial.
  intros pbn' H.
  unfold chip_get_block.
  unfold chip_set_block in Hsetc.
  destruct (bvalid_block_no pbn) eqn: Hvb; try discriminate.
  destruct (list_set (chip_blocks c) pbn b) eqn: Hset; try discriminate.
  injection Hsetc.
  intro; subst c'.
  simpl.
  rewrite (list_get_list_set_neq Hset H).
  trivial.
Qed.

Lemma nand_read_page_eq_in_same_block :
  forall c pbn off c',
    chip_get_block c pbn = chip_get_block c' pbn
    -> nand_read_page c pbn off = nand_read_page c' pbn off.
Proof.
  intros c pbn off c' Hc.
  unfold nand_read_page.
  destruct (bvalid_block_no pbn) eqn:Hpbn.
  rewrite <- Hc.
  trivial.
  trivial.
Qed.

Lemma invalid_off_implies_nand_read_page_none :
  forall c pbn loc,
    bvalid_page_off loc = false
    -> nand_read_page c pbn loc = None.
Proof.
  intros c pbn loc H.
  unfold nand_read_page.
  rewrite H.
  destruct (bvalid_block_no pbn); trivial.
  destruct (chip_get_block c pbn); trivial.
Qed.

Lemma nand_write_page_spec:
  forall c pbn off d o b p,
    bvalid_block_no pbn = true
    -> bvalid_page_off off = true
    -> chip_get_block c pbn = Some b
    -> block_get_page b off = Some p
    -> ble_nat (next_page b) off = true
    -> page_state p = ps_free
    -> exists c', nand_write_page c pbn off d o = Some c'
               /\ (exists b', chip_get_block c' pbn = Some b'
                              /\ next_page b' = S off
                              /\ block_erase_count b' = block_erase_count b
                              /\ block_state b' = bs_programmed
                              /\ (exists p', block_get_page b' off = Some p'
                                            /\ p' = mkpage d o ps_programmed)
                              /\ forall off',
                                   off' <> off
                                   -> bvalid_page_off off' = true
                                   -> block_get_page b' off' = block_get_page b off')
               /\ (forall pbn',
                     pbn' <> pbn
                     -> chip_get_block c pbn' = chip_get_block c' pbn').
Proof.
  intros c pbn off d o b p.
  intros Hvb Hvo Hc Hb Hnp Hps.
  unfold nand_write_page.
  rewrite Hvb.
  rewrite Hc.
  rewrite Hvo.
  rewrite Hnp.
  rewrite Hb.
  destruct (check_page_state_is_free (page_state p)) eqn:Hck.
  assert (exists b', block_set_page b off (mkpage d o ps_programmed) = Some b').
    unfold block_set_page.
    rewrite Hvo.
    unfold block_get_page in Hb.
    rewrite Hvo in Hb.
    destruct (list_get (block_pages b) off) eqn: Hgb; (try discriminate).
    injection Hb.
    intro; subst p0.
    destruct (list_get_list_set (mkpage d o ps_programmed) Hgb) as [b' Hsetb'].
    rewrite Hsetb'.
    eexists; eauto.
  destruct H as [b' Hb'].
  rewrite Hb'.
  unfold block_set_next_page.
  assert (exists c', chip_set_block c pbn
                                    (mkblock (block_pages b') (S off)
                                             (block_erase_count b') (block_state b')) = Some c').
    unfold chip_set_block.
    rewrite Hvb.
    unfold chip_get_block in Hc.
    destruct (list_get (chip_blocks c) pbn) eqn: Hgb; (try discriminate).
    injection Hc.
    intro; subst b0.
    destruct (list_get_list_set (mkblock (block_pages b') (S off)
                                             (block_erase_count b') (block_state b')) Hgb) as [c' Hsetc'].
    rewrite Hsetc'.
    eexists; eauto.
  destruct H as [c' Hc'].
  rewrite Hc'.
  exists c'.
  split; trivial.
  split.
    exists (mkblock (block_pages b') (S off)
                    (block_erase_count b') (block_state b')).
    split.
      unfold chip_get_block.
      unfold chip_set_block in Hc'.
      rewrite Hvb in Hc'.
      destruct (list_set (chip_blocks c) pbn (mkblock (block_pages b') (S off)
                    (block_erase_count b') (block_state b'))) eqn: Hset; try discriminate.
      injection Hc'; intro; subst c'.
      simpl.
      apply list_get_list_set_eq with (chip_blocks c); trivial.
    split.
      simpl.
      trivial.
    split.
      simpl.
      unfold block_set_page in Hb'.
      rewrite Hvo in Hb'.
      destruct (list_set (block_pages b) off (mkpage d o ps_programmed)) eqn: Hset; try discriminate.
      injection Hb'; intro; subst.
      simpl.
      trivial.
    split.
      simpl.
      unfold block_set_page in Hb'.
      rewrite Hvo in Hb'.
      destruct (list_set (block_pages b) off (mkpage d o ps_programmed)) eqn: Hset; try discriminate.
      injection Hb'; intro; subst.
      simpl.
      trivial.
    split.
      exists (mkpage d o ps_programmed).
      split; trivial.
      unfold block_get_page.
      rewrite Hvo.
      simpl.
      unfold block_set_page in Hb'.
      rewrite Hvo in Hb'.
      destruct (list_set (block_pages b) off (mkpage d o ps_programmed)) eqn: Hset; try discriminate.
      injection Hb'; intro; subst b'.
      simpl in * .
      rewrite (list_get_list_set_eq Hset).
      trivial.
    intros off' Hoff' Hvo'.
    unfold block_get_page.
    unfold block_set_page in Hb'.
    rewrite Hvo in Hb'.
    rewrite Hvo'.
    simpl.
    destruct (list_set (block_pages b) off (mkpage d o ps_programmed)) eqn:Hset; try discriminate.
    rewrite <- (list_get_list_set_neq Hset (neq_sym Hoff')).
    injection Hb'; intro; subst b'.
    simpl in * .
    trivial.
  intros pbn' Hneq.
  unfold chip_get_block.
  unfold chip_set_block in Hc'.
  rewrite Hvb in Hc'.
  destruct (list_set (chip_blocks c) pbn (mkblock (block_pages b') (S off)
                    (block_erase_count b') (block_state b'))) eqn:Hset; try discriminate.
  injection Hc'; intro; subst c'.
  simpl.
  rewrite (list_get_list_set_neq Hset (neq_sym Hneq)).
  trivial.

  unfold check_page_state_is_free in Hck.
  rewrite Hps in Hck.
  discriminate.
Qed.


Require Import VST.floyd.proofauto.
Require Import tree_copy.
From SSL_VST Require Import core.
Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Definition malloc_spec :=
  DECLARE _malloc
        WITH t: type
        PRE [ tuint ]
        PROP()
        PARAMS(Vint (Int.repr (sizeof t)))
        SEP()
        POST [tptr tvoid] EX p:_,
        PROP()
        RETURN(p)
        SEP(data_at_ Tsh t p).

Inductive tree_card : Set :=
    | tree_card_0 : tree_card
    | tree_card_2 : tree_card -> tree_card -> tree_card.

Fixpoint tree (x: val) (s: (list Z)) (self_card: tree_card) {struct self_card} : mpred := match self_card with
    | tree_card_0  =>  !!((x : val) = nullval) && !!((s : list Z) = ([] : list Z)) && emp
    | tree_card_2 _alpha_514 _alpha_513 =>
      EX v : Z,
      EX s2 : (list Z),
      EX r : val,
      EX s1 : (list Z),
      EX l : val,
 !!(Int.min_signed <= v <= Int.max_signed) && !!(is_pointer_or_null r) && !!(is_pointer_or_null l) && !!(~ ((x : val) = nullval)) && !!((s : list Z) = ((([(v : Z)] : list Z) ++ (s1 : list Z)) ++ (s2 : list Z))) && (data_at Tsh (tarray (Tunion _sslval noattr) 3) [(inl ((Vint (Int.repr v)) : val)); (inr (l : val)); (inr (r : val))] (x : val)) * (tree (l : val) (s1 : list Z) (_alpha_513 : tree_card)) * (tree (r : val) (s2 : list Z) (_alpha_514 : tree_card))
end.

Inductive treeN_card : Set :=
    | treeN_card_0 : treeN_card
    | treeN_card_2 : treeN_card -> treeN_card -> treeN_card.

Fixpoint treeN (x: val) (n: Z) (self_card: treeN_card) {struct self_card} : mpred := match self_card with
    | treeN_card_0  =>  !!((x : val) = nullval) && !!((n : Z) = 0) && emp
    | treeN_card_2 _alpha_516 _alpha_515 =>
      EX n1 : Z,
      EX v : val,
      EX r : val,
      EX n2 : Z,
      EX l : val,
 !!(Int.min_signed <= n1 <= Int.max_signed) && !!(is_pointer_or_null v) && !!(is_pointer_or_null r) && !!(Int.min_signed <= n2 <= Int.max_signed) && !!(is_pointer_or_null l) && !!(~ ((x : val) = nullval)) && !!(0 <= (n1 : Z)) && !!(0 <= (n2 : Z)) && !!((n : Z) = ((1 + (n1 : Z)) + (n2 : Z))) && (data_at Tsh (tarray (Tunion _sslval noattr) 3) [(inr (v : val)); (inr (l : val)); (inr (r : val))] (x : val)) * (treeN (l : val) (n1 : Z) (_alpha_515 : treeN_card)) * (treeN (r : val) (n2 : Z) (_alpha_516 : treeN_card))
end.

Inductive sll_card : Set :=
    | sll_card_0 : sll_card
    | sll_card_1 : sll_card -> sll_card.

Fixpoint sll (x: val) (s: (list Z)) (self_card: sll_card) {struct self_card} : mpred := match self_card with
    | sll_card_0  =>  !!((x : val) = nullval) && !!((s : list Z) = ([] : list Z)) && emp
    | sll_card_1 _alpha_517 =>
      EX v : Z,
      EX s1 : (list Z),
      EX nxt : val,
 !!(Int.min_signed <= v <= Int.max_signed) && !!(is_pointer_or_null nxt) && !!(~ ((x : val) = nullval)) && !!((s : list Z) = (([(v : Z)] : list Z) ++ (s1 : list Z))) && (data_at Tsh (tarray (Tunion _sslval noattr) 2) [(inl ((Vint (Int.repr v)) : val)); (inr (nxt : val))] (x : val)) * (sll (nxt : val) (s1 : list Z) (_alpha_517 : sll_card))
end.

Definition tree_copy_spec :=
  DECLARE _tree_copy
   WITH r: val, x: val, s: (list Z), a: tree_card
   PRE [ (tptr (Tunion _sslval noattr)) ]
   PROP( is_pointer_or_null((r : val)); is_pointer_or_null((x : val)) )
   PARAMS(r)
   SEP ((data_at Tsh (tarray (Tunion _sslval noattr) 1) [(inr (x : val))] (r : val)); (tree (x : val) (s : list Z) (a : tree_card)))
   POST[ tvoid ]
   EX y: val,
   PROP( is_pointer_or_null((y : val)) )
   LOCAL()
   SEP ((data_at Tsh (tarray (Tunion _sslval noattr) 1) [(inr (y : val))] (r : val)); (tree (x : val) (s : list Z) (a : tree_card)); (tree (y : val) (s : list Z) (a : tree_card))).

Lemma tree_x_valid_pointerP x s self_card: tree x s self_card |-- valid_pointer x. Proof. destruct self_card; simpl; entailer;  entailer!; eauto. Qed.
Hint Resolve tree_x_valid_pointerP : valid_pointer.
Lemma tree_local_factsP x s self_card :
  tree x s self_card|-- !!(((((x : val) = nullval)) -> (self_card = tree_card_0))/\(((~ ((x : val) = nullval))) -> (exists _alpha_514 _alpha_513, self_card = tree_card_2 _alpha_514 _alpha_513))/\is_pointer_or_null((x : val))).
 Proof.  destruct self_card;  simpl; entailer; saturate_local; apply prop_right; eauto. Qed.
Hint Resolve tree_local_factsP : saturate_local.
Lemma unfold_tree_card_0  (x: val) (s: (list Z)) : tree x s (tree_card_0 ) =  !!((x : val) = nullval) && !!((s : list Z) = ([] : list Z)) && emp. Proof. auto. Qed.
Lemma unfold_tree_card_2 (_alpha_514 : tree_card) (_alpha_513 : tree_card) (x: val) (s: (list Z)) : tree x s (tree_card_2 _alpha_514 _alpha_513) =
      EX v : Z,
      EX s2 : (list Z),
      EX r : val,
      EX s1 : (list Z),
      EX l : val,
 !!(Int.min_signed <= v <= Int.max_signed) && !!(is_pointer_or_null r) && !!(is_pointer_or_null l) && !!(~ ((x : val) = nullval)) && !!((s : list Z) = ((([(v : Z)] : list Z) ++ (s1 : list Z)) ++ (s2 : list Z))) && (data_at Tsh (tarray (Tunion _sslval noattr) 3) [(inl ((Vint (Int.repr v)) : val)); (inr (l : val)); (inr (r : val))] (x : val)) * (tree (l : val) (s1 : list Z) (_alpha_513 : tree_card)) * (tree (r : val) (s2 : list Z) (_alpha_514 : tree_card)). Proof. auto. Qed.
Lemma treeN_x_valid_pointerP x n self_card: treeN x n self_card |-- valid_pointer x. Proof. destruct self_card; simpl; entailer;  entailer!; eauto. Qed.
Hint Resolve treeN_x_valid_pointerP : valid_pointer.
Lemma treeN_local_factsP x n self_card :
  treeN x n self_card|-- !!(((((x : val) = nullval)) -> (self_card = treeN_card_0))/\(((~ ((x : val) = nullval))) -> (exists _alpha_516 _alpha_515, self_card = treeN_card_2 _alpha_516 _alpha_515))/\is_pointer_or_null((x : val))).
 Proof.  destruct self_card;  simpl; entailer; saturate_local; apply prop_right; eauto. Qed.
Hint Resolve treeN_local_factsP : saturate_local.
Lemma unfold_treeN_card_0  (x: val) (n: Z) : treeN x n (treeN_card_0 ) =  !!((x : val) = nullval) && !!((n : Z) = 0) && emp. Proof. auto. Qed.
Lemma unfold_treeN_card_2 (_alpha_516 : treeN_card) (_alpha_515 : treeN_card) (x: val) (n: Z) : treeN x n (treeN_card_2 _alpha_516 _alpha_515) =
      EX n1 : Z,
      EX v : val,
      EX r : val,
      EX n2 : Z,
      EX l : val,
 !!(Int.min_signed <= n1 <= Int.max_signed) && !!(is_pointer_or_null v) && !!(is_pointer_or_null r) && !!(Int.min_signed <= n2 <= Int.max_signed) && !!(is_pointer_or_null l) && !!(~ ((x : val) = nullval)) && !!(0 <= (n1 : Z)) && !!(0 <= (n2 : Z)) && !!((n : Z) = ((1 + (n1 : Z)) + (n2 : Z))) && (data_at Tsh (tarray (Tunion _sslval noattr) 3) [(inr (v : val)); (inr (l : val)); (inr (r : val))] (x : val)) * (treeN (l : val) (n1 : Z) (_alpha_515 : treeN_card)) * (treeN (r : val) (n2 : Z) (_alpha_516 : treeN_card)). Proof. auto. Qed.
Lemma sll_x_valid_pointerP x s self_card: sll x s self_card |-- valid_pointer x. Proof. destruct self_card; simpl; entailer;  entailer!; eauto. Qed.
Hint Resolve sll_x_valid_pointerP : valid_pointer.
Lemma sll_local_factsP x s self_card :
  sll x s self_card|-- !!(((((x : val) = nullval)) -> (self_card = sll_card_0))/\(((~ ((x : val) = nullval))) -> (exists _alpha_517, self_card = sll_card_1 _alpha_517))/\is_pointer_or_null((x : val))).
 Proof.  destruct self_card;  simpl; entailer; saturate_local; apply prop_right; eauto. Qed.
Hint Resolve sll_local_factsP : saturate_local.
Lemma unfold_sll_card_0  (x: val) (s: (list Z)) : sll x s (sll_card_0 ) =  !!((x : val) = nullval) && !!((s : list Z) = ([] : list Z)) && emp. Proof. auto. Qed.
Lemma unfold_sll_card_1 (_alpha_517 : sll_card) (x: val) (s: (list Z)) : sll x s (sll_card_1 _alpha_517) =
      EX v : Z,
      EX s1 : (list Z),
      EX nxt : val,
 !!(Int.min_signed <= v <= Int.max_signed) && !!(is_pointer_or_null nxt) && !!(~ ((x : val) = nullval)) && !!((s : list Z) = (([(v : Z)] : list Z) ++ (s1 : list Z))) && (data_at Tsh (tarray (Tunion _sslval noattr) 2) [(inl ((Vint (Int.repr v)) : val)); (inr (nxt : val))] (x : val)) * (sll (nxt : val) (s1 : list Z) (_alpha_517 : sll_card)). Proof. auto. Qed.
Definition Gprog : funspecs :=
  ltac:(with_library prog [tree_copy_spec; malloc_spec]).

Lemma body_tree_copy : semax_body Vprog Gprog f_tree_copy tree_copy_spec.
Proof.
start_function.
ssl_open_context.
assert_PROP (isptr r). { entailer!. }
try rename x into x2.
forward.
forward_if.

 - {
assert_PROP (a = tree_card_0) as ssl_card_assert. { entailer!; ssl_dispatch_card. }
ssl_card tree ssl_card_assert .
assert_PROP (((x2 : val) = nullval)). { entailer!. }
let ssl_var := fresh in assert_PROP(s = ([] : list Z)) as ssl_var; try rewrite ssl_var in *. { entailer!. }
forward; entailer!.
Exists nullval.
ssl_entailer.
rewrite (unfold_tree_card_0 ) at 1.
ssl_entailer.
rewrite (unfold_tree_card_0 ) at 1.
ssl_entailer.

}
 - {
assert_PROP (exists _alpha_514 _alpha_513, a = tree_card_2 _alpha_514 _alpha_513) as ssl_card_assert. { entailer!; ssl_dispatch_card. }
ssl_card tree ssl_card_assert _alpha_514x2 _alpha_513x2.
assert_PROP ((~ ((x2 : val) = nullval))). { entailer!. }
Intros vx2 s2x2 rx2 s1x2 lx2.
let ssl_var := fresh in assert_PROP(s = ((([(vx2 : Z)] : list Z) ++ (s1x2 : list Z)) ++ (s2x2 : list Z))) as ssl_var; try rewrite ssl_var in *. { entailer!. }
try rename vx2 into vx22.
forward.
try rename lx2 into lx22.
forward.
try rename rx2 into rx22.
forward.
forward.
assert_PROP(is_pointer_or_null((r : val))). { entailer!. }
assert_PROP(is_pointer_or_null((lx22 : val))). { entailer!. }
forward_call ((r : val), (lx22 : val), (s1x2 : list Z), (_alpha_513x2 : tree_card)).
Intros y1.
assert_PROP(is_pointer_or_null((lx22 : val))). { entailer!. }
assert_PROP(is_pointer_or_null((y1 : val))). { entailer!. }
try rename y1 into y12.
forward.
forward.
assert_PROP(is_pointer_or_null((r : val))). { entailer!. }
assert_PROP(is_pointer_or_null((rx22 : val))). { entailer!. }
forward_call ((r : val), (rx22 : val), (s2x2 : list Z), (_alpha_514x2 : tree_card)).
Intros y2.
assert_PROP(is_pointer_or_null((rx22 : val))). { entailer!. }
assert_PROP(is_pointer_or_null((y2 : val))). { entailer!. }
try rename y2 into y22.
forward.
forward_call (tarray (Tunion _sslval noattr) 3).
Intros y3.
assert_PROP (isptr y3). { entailer!. }
forward.
forward.
forward.
forward.
forward; entailer!.
Exists (y3 : val).
ssl_entailer.
rewrite (unfold_tree_card_2 (_alpha_514x2 : tree_card) (_alpha_513x2 : tree_card)) at 1.
Exists (vx22 : Z).
Exists (s2x2 : list Z).
Exists (rx22 : val).
Exists (s1x2 : list Z).
Exists (lx22 : val).
ssl_entailer.
rewrite (unfold_tree_card_2 (_alpha_514x2 : tree_card) (_alpha_513x2 : tree_card)) at 1.
Exists (vx22 : Z).
Exists (s2x2 : list Z).
Exists (y22 : val).
Exists (s1x2 : list Z).
Exists (y12 : val).
ssl_entailer.

}
Qed.


Require Import compcert.common.AST.
Require Import compcert.common.Values.
Require Import compcert.common.Memory.
Require Import oeuf.SafeInt.
Require Import oeuf.SafeDouble.

Require Import ZArith.

Require Import oeuf.MemInjProps.

Require Import StructTact.StructTactics.
Require Import oeuf.StuartTact.

Inductive opaque_type_name : Set :=
| Oint
| Odouble
.

Definition opaque_type_name_eq_dec (n1 n2 : opaque_type_name) :
        { n1 = n2 } + { n1 <> n2 }.
decide equality.
Defined.
Hint Resolve opaque_type_name_eq_dec : eq_dec.

Definition opaque_type_denote oty : Type :=
    match oty with
    | Oint => int
    | Odouble => float
    end.

Definition opaque_type_denote_eq_dec oty (x y : opaque_type_denote oty) :
        { x = y } + { x <> y }.
destruct oty; simpl in x, y.
- eapply Int.eq_dec.
- eapply Float.eq_dec.
Defined.

Record opaque_type_impl {oty} := MkOpaqueTypeImpl {
    ot_value_inject : opaque_type_denote oty -> val -> mem -> Prop;
    (* We may eventually need to split this into separate helper lemmas for
       value_val_inject and value_inject_mem_extends.  Currently we use a
       slightly weaker precondition in order to use a single helper lemma for
       both. *)
    ot_value_val_inject : forall mi m m' cv cv' ov,
        ot_value_inject ov cv m ->
        Val.inject mi cv cv' ->
        Mem.mem_inj mi m m' ->
        same_offsets mi ->
        ot_value_inject ov cv' m';
    ot_inject_defined : forall ov cv m,
        ot_value_inject ov cv m ->
        cv <> Vundef;
    ot_value_32bit : forall ov cv m,
        ot_value_inject ov cv m ->
        Val.load_result Mint32 cv = cv;
    (* ot_mem_inj : forall mi m m' cv ov, *)
    (*     ot_value_inject ov cv m -> *)
    (*     Mem.mem_inj mi m m' -> *)
    (*     (forall b, Mem.valid_block m b -> mi b <> None) -> *)
    (*     exists cv', *)
    (*         ot_value_inject ov cv' m' /\ *)
    (*         Val.inject mi cv cv'; *)
    ot_mem_inj_strict : forall mi m m' cv ov,
        ot_value_inject ov cv m ->
        Mem.mem_inj mi m m' ->
        (forall b, Mem.valid_block m b -> mi b = Some (b, 0%Z)) ->
        Val.inject mi cv cv;
    ot_ptr_block_valid : forall ov m b ofs,
        ot_value_inject ov (Vptr b ofs) m ->
        Mem.valid_block m b
}.

Implicit Arguments opaque_type_impl [].

Definition impl_int : opaque_type_impl Oint.
simple refine (MkOpaqueTypeImpl _  _  _ _ _ _ _).

- exact (fun ov cv m => cv = Vint ov).

- intros. simpl in *. on >Val.inject, invc; congruence.

- intros. simpl in *. congruence.

- intros. simpl in *. subst cv. reflexivity.

- intros. simpl in *. subst cv. eauto.

- intros. simpl in *. discriminate.
Defined.

Definition impl_double : opaque_type_impl Odouble.
  simple refine (MkOpaqueTypeImpl _ _ _ _ _ _ _).

  - intros ov cv m.
    exact (exists b,
              exists ofs,
                cv = Vptr b ofs /\
                Mem.load Mfloat64 m b (Int.unsigned ofs) = Some (Vfloat ov)).
  - intros. simpl in *.
    repeat break_exists.
    repeat break_and.
    on >Val.inject, invc;
      try congruence.
    inversion H6. subst.
    exists b2.
    unfold same_offsets in *.
    remember H4 as Hmi.
    clear HeqHmi.
    eapply H2 in H4. subst delta.
    eexists.
    split.
    reflexivity.
    eapply Mem.load_inj in H3; eauto.
    break_exists.
    break_and.
    inversion H0. subst.
    rewrite <- H.
    f_equal.
    rewrite Int.add_unsigned.
    fold Int.zero.
    rewrite Int.unsigned_zero.
    rewrite Int.unsigned_repr.
    reflexivity.
    rewrite Z.add_0_r.
    eapply Int.unsigned_range_2.

  - intros. simpl in H.
    repeat break_exists.
    repeat break_and.
    congruence.

  - intros. simpl in H.
    repeat break_exists.
    break_and.
    subst cv.

    reflexivity.

  - intros.
    simpl in H.
    repeat break_exists.
    break_and. subst cv.

    assert (Mem.valid_block m x).
    eapply Mem.valid_access_valid_block.
    eapply Mem.valid_access_implies.
    eapply Mem.load_valid_access; eauto.
    econstructor.

    eapply H1 in H.
    econstructor; eauto.
    unfold Int.add.
    rewrite Int.unsigned_repr.
    rewrite Z.add_0_r.
    rewrite Int.repr_unsigned.
    reflexivity.
    unfold Int.max_unsigned.
    unfold Int.modulus.
    simpl.
    omega.

  - intros.
    simpl in H.
    repeat break_exists.
    break_and.
    inversion H.
    subst.

    eapply Mem.valid_access_valid_block.
    eapply Mem.valid_access_implies.
    eapply Mem.load_valid_access; eauto.
    econstructor.
Defined.

Definition get_opaque_type_impl oty :=
    match oty with
    | Oint => impl_int
    | Odouble => impl_double
    end.

Section BY_NAME.
Local Set Implicit Arguments.

Variable oty : opaque_type_name.
Let impl := get_opaque_type_impl oty.

Definition opaque_type_value_inject := ot_value_inject impl.

Lemma opaque_type_value_val_inject : forall mi m m' cv cv' ov,
        opaque_type_value_inject ov cv m ->
        Val.inject mi cv cv' ->
        Mem.mem_inj mi m m' ->
        same_offsets mi ->
        opaque_type_value_inject ov cv' m'.
intros. unfold opaque_type_value_inject in *.
eapply (ot_value_val_inject impl); eauto.
Qed.

Lemma opaque_type_inject_defined : forall ov cv m,
        opaque_type_value_inject ov cv m ->
        cv <> Vundef.
intros. unfold opaque_type_value_inject in *.
eapply (ot_inject_defined impl); eauto.
Qed.

Lemma opaque_type_value_32bit : forall ov cv m,
        opaque_type_value_inject ov cv m ->
        Val.load_result Mint32 cv = cv.
intros. unfold opaque_type_value_inject in *.
eapply (ot_value_32bit impl); eauto.
Qed.

(* Lemma opaque_type_mem_inj : forall mi m m' cv ov, *)
(*     opaque_type_value_inject ov cv m -> *)
(*     Mem.mem_inj mi m m' -> *)
(*     (forall b, Mem.valid_block m b -> mi b <> None) -> *)
(*     exists cv', *)
(*         opaque_type_value_inject ov cv' m' /\ *)
(*         Val.inject mi cv cv'. *)
(* intros. unfold opaque_type_value_inject in *. *)
(* eapply (ot_mem_inj impl); eauto. *)
(* Qed. *)

Lemma opaque_type_mem_inj_strict : forall mi m m' cv ov,
    opaque_type_value_inject ov cv m ->
    Mem.mem_inj mi m m' ->
    (forall b, Mem.valid_block m b -> mi b = Some (b, 0%Z)) ->
    Val.inject mi cv cv.
intros. unfold opaque_type_value_inject in *.
eapply (ot_mem_inj_strict impl); eauto.
Qed.

Lemma opaque_type_ptr_block_valid : forall ov m b ofs,
    opaque_type_value_inject ov (Vptr b ofs) m ->
    Mem.valid_block m b.
intros. unfold opaque_type_value_inject in *.
eapply (ot_ptr_block_valid impl); eauto.
Qed.

End BY_NAME.


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

Require Import Coq.Arith.Arith Coq.Vectors.Vector
     Coq.NArith.NArith.
Require Import Cava.Arrow.ArrowExport.

Require Import Aes.Pkg.

Import VectorNotations.
Import KappaNotation.
Open Scope kind_scope.

(* module aes_shift_rows (
  input  aes_pkg::ciph_op_e    op_i,
  input  logic [3:0][3:0][7:0] data_i,
  output logic [3:0][3:0][7:0] data_o
); *)
Definition aes_shift_rows
  : <<Bit, Vector (Vector (Vector Bit 8) 4) 4, Unit>> ~> Vector (Vector (Vector Bit 8) 4) 4 :=
  <[\op_i data_i =>
  (* // Row 0 is left untouched *)
  (* assign data_o[0] = data_i[0]; *)
    let data_o_0 = data_i[#0] in
  (* // Row 2 does not depend on op_i *)
  (* assign data_o[2] = aes_circ_byte_shift(data_i[2], 2'h2); *)
    let data_o_2 = !aes_circ_byte_shift data_i[#2] (#2) in

  (* // Row 1 *)
  (* assign data_o[1] = (op_i == CIPH_FWD) ? aes_circ_byte_shift(data_i[1], 2'h3) *)
  (*                                       : aes_circ_byte_shift(data_i[1], 2'h1); *)
    let data_o_1 =
      if op_i == !CIPH_FWD
      then !aes_circ_byte_shift data_i[#1] #3
      else !aes_circ_byte_shift data_i[#1] #1
      in
  (* // Row 3 *)
  (* assign data_o[3] = (op_i == CIPH_FWD) ? aes_circ_byte_shift(data_i[3], 2'h1) *)
  (*                                       : aes_circ_byte_shift(data_i[3], 2'h3); *)
    let data_o_3 =
      if op_i == !CIPH_FWD
      then !aes_circ_byte_shift data_i[#3] #1
      else !aes_circ_byte_shift data_i[#3] #3
      in
    data_o_0 :: data_o_1 :: data_o_2 :: data_o_3 :: []
  ]>.

Definition shift_rows_composed
:  << Vector _ 4, Unit>> ~> (Vector _ 4) :=
  <[\input =>
  let encoded = !aes_shift_rows !CIPH_FWD input in
  let decoded = !aes_shift_rows !CIPH_INV encoded in
  decoded ]>.


Set Warnings "-notation-overridden,-parsing".
From Coq Require Import Strings.String.
From Coq Require Import Arith.Arith.
From Coq Require Import Lia.
From PLF Require Import Maps.
From PLF Require Smallstep.
From Coq Require Import Lists.List.

Inductive ty : Type :=
  | Ty_Nat   : ty
  | Ty_Unit  : ty
  | Ty_Arrow : ty -> ty -> ty
  | Ty_Ref   : ty -> ty.

Inductive tm  : Type :=
  (* STLC with numbers: *)
  | tm_var    : string -> tm
  | tm_app    : tm -> tm -> tm
  | tm_abs    : string -> ty -> tm -> tm
  | tm_const  : nat -> tm
  | tm_succ    : tm -> tm
  | tm_pred    : tm -> tm
  | tm_mult    : tm -> tm -> tm
  | tm_if0  : tm -> tm -> tm -> tm
  (* Ref new terms: *)
  | tm_unit   : tm
  | tm_ref    : tm -> tm
  | tm_deref  : tm -> tm
  | tm_assign : tm -> tm -> tm
  | tm_loc    : nat -> tm
  (* GC new term: *)
  | tm_free   : tm -> tm
.

Declare Custom Entry stlc.
Notation "<{ e }>" := e (e custom stlc at level 99).
Notation "( x )" := x (in custom stlc, x at level 99).
Notation "x" := x (in custom stlc at level 0, x constr at level 0).
Notation "S -> T" := (Ty_Arrow S T) (in custom stlc at level 50, right associativity).
Notation "x y" := (tm_app x y) (in custom stlc at level 1, left associativity).
Notation "\ x : t , y" :=
  (tm_abs x t y) (in custom stlc at level 90, x at level 99,
                     t custom stlc at level 99,
                     y custom stlc at level 99,
                     left associativity).
Coercion tm_var : string >-> tm.

Notation "{ x }" := x (in custom stlc at level 0, x constr).

Notation "'Unit'" :=
  (Ty_Unit) (in custom stlc at level 0).
Notation "'unit'" := tm_unit (in custom stlc at level 0).

Notation "'Natural'" := Ty_Nat (in custom stlc at level 0).
Notation "'succ' x" := (tm_succ x) (in custom stlc at level 0,
                                     x custom stlc at level 0).
Notation "'pred' x" := (tm_pred x) (in custom stlc at level 0,
                                     x custom stlc at level 0).
Notation "x * y" := (tm_mult x y) (in custom stlc at level 1,
                                      left associativity).
Notation "'if0' x 'then' y 'else' z" :=
  (tm_if0 x y z) (in custom stlc at level 89,
                    x custom stlc at level 99,
                    y custom stlc at level 99,
                    z custom stlc at level 99,
                    left associativity).
Coercion tm_const : nat >-> tm.

Notation "'Ref' t" :=
  (Ty_Ref t) (in custom stlc at level 4).
Notation "'loc' x" := (tm_loc x) (in custom stlc at level 2).
Notation "'ref' x" := (tm_ref x) (in custom stlc at level 2).
Notation "'!' x " := (tm_deref x) (in custom stlc at level 2).
Notation " e1 ':=' e2 " := (tm_assign e1 e2) (in custom stlc at level 21).
Notation "'free' x" := (tm_free x) (in custom stlc at level 2).

Print Scopes.

Definition store := list (option tm).

Inductive store_lookup : nat -> store -> tm -> Prop :=
  | SL_found : forall r t, store_lookup 0 ((Some t) :: r) t
  | SL_next n r t (H: store_lookup n r t) : forall x, store_lookup (S n) (x :: r) t.

Inductive store_assign : store -> nat -> tm -> store -> Prop :=
  | SA_here : forall x r t, store_assign ((Some x) :: r) 0 t ((Some t)::r)
  | SA_next s n t s' x (H : store_assign s n t s') :
      store_assign (x::s) (S n) t (x::s')
.

Inductive store_assign_new : store -> nat -> tm -> store -> Prop :=
  | SAN_here : forall r t, store_assign_new (None :: r) 0 t ((Some t)::r)
  | SAN_next s n t s' x (H : store_assign_new s n t s') :
      store_assign_new (x::s) (S n) t (x::s')
.

Inductive store_free : store -> nat -> store -> Prop :=
  | SF_here : forall x r, store_free (Some x :: r) 0 (None::r)
  | SF_next s n s' x (H : store_free s n s') :
      store_free (x::s) (S n) (x::s')
.

Inductive first_empty_cell : store -> nat -> Prop :=
  | FEC_found : forall r, first_empty_cell (None :: r) 0
  | FEC_next s n (H: first_empty_cell s n) :
      forall x, first_empty_cell ((Some x) :: s) (S n)
.

Inductive value : tm -> Prop :=
  | v_abs : forall x T2 t1,
      value <{\x:T2, t1}>
  | v_nat : forall n : nat ,
      value <{ n }>
  | v_unit :
      value <{ unit }>
  | v_loc : forall l,
         value <{ loc l }>.

Hint Constructors value : core.

(** Extending substitution to handle the new syntax of terms is
    straightforward.  *)

Reserved Notation "'[' x ':=' s ']' t" (in custom stlc at level 20, x constr).
Fixpoint subst (x : string) (s : tm) (t : tm) : tm :=
  match t with
  (* pure STLC *)
  | tm_var y =>
      if eqb_string x y then s else t
  | <{\y:T, t1}> =>
      if eqb_string x y then t else <{\y:T, [x:=s] t1}>
  | <{t1 t2}> =>
      <{([x:=s] t1) ([x:=s] t2)}>
  (* numbers *)
  | tm_const _ =>
      t
  | <{succ t1}> =>
      <{succ [x := s] t1}>
  | <{pred t1}> =>
      <{pred [x := s] t1}>
  | <{t1 * t2}> =>
      <{ ([x := s] t1) * ([x := s] t2)}>
  | <{if0 t1 then t2 else t3}> =>
      <{if0 [x := s] t1 then [x := s] t2 else [x := s] t3}>
  (* unit *)
  | <{ unit }> =>
    <{ unit }>
  (* references *)
  | <{ ref t1 }> =>
      <{ ref ([x:=s] t1) }>
  | <{ !t1 }> =>
      <{ !([x:=s] t1) }>
  | <{ t1 := t2 }> =>
    <{ ([x:=s] t1) := ([x:=s] t2) }>
  | <{ loc _ }> =>
      t
  | <{ free t }> =>
    <{ free [x:=s]t }>
  end

where "'[' x ':=' s ']' t" := (subst x s t) (in custom stlc).

Reserved Notation "t / st --> t' / st'"
  (at level 40, st at level 39, t' at level 39).

Inductive step : tm * store -> tm * store -> Prop :=
  | ST_AppAbs : forall x T2 t1 v2 st,
         value v2 ->
         <{ (\x : T2, t1) v2 }> / st --> <{ [x := v2] t1 }> / st
  | ST_App1 : forall t1 t1' t2 st st',
         t1 / st --> t1' / st' ->
         <{ t1 t2 }> / st --> <{ t1' t2 }> / st'
  | ST_App2 : forall v1 t2 t2' st st',
         value v1 ->
         t2 / st --> t2' / st' ->
         <{ v1 t2 }> / st --> <{ v1 t2' }> / st'
  (* numbers *)
  | ST_SuccNatural : forall (n : nat) st,
         <{ succ n }> / st --> tm_const (S n) / st
  | ST_Succ : forall t1 t1' st st',
         t1 / st --> t1' / st' ->
         <{ succ t1 }> / st --> <{ succ t1' }> / st'
  | ST_PredNatural : forall (n : nat) st,
         <{ pred n }> / st --> tm_const (n - 1) / st
  | ST_Pred : forall t1 t1' st st',
         t1 / st --> t1' / st' ->
         <{ pred t1 }> / st --> <{ pred t1' }> / st'
  | ST_MultNaturals : forall (n1 n2 : nat) st,
      <{ n1 * n2 }> / st -->  tm_const (n1 * n2) / st
  | ST_Mult1 : forall t1 t2 t1' st st',
         t1 / st --> t1' / st' ->
         <{ t1 * t2 }> / st --> <{ t1' * t2 }> / st'
  | ST_Mult2 : forall v1 t2 t2' st st',
         value v1 ->
         t2 / st --> t2' / st' ->
         <{ v1 * t2 }> / st --> <{ v1 * t2' }> / st'
  | ST_If0 : forall t1 t1' t2 t3 st st',
         t1 / st --> t1' / st' ->
         <{ if0 t1 then t2 else t3 }> / st --> <{ if0 t1' then t2 else t3 }> / st'
  | ST_If0_Zero : forall t2 t3 st,
         <{ if0 0 then t2 else t3 }> / st --> t2 / st
  | ST_If0_Nonzero : forall n t2 t3 st,
         <{ if0 {S n} then t2 else t3 }> / st --> t3 / st
  (* references *)
  | ST_RefValue : forall v st st' n,
         value v ->
         first_empty_cell st n ->
         store_assign_new st n v st' ->
         <{ ref v }> / st --> <{ loc n }> / st'
  | ST_Ref : forall t1 t1' st st',
         t1 / st --> t1' / st' ->
         <{ ref t1 }> /  st --> <{ ref t1' }> /  st'
  | ST_DerefLoc : forall st n t,
         store_lookup n st t ->
         <{ !(loc n) }> / st --> <{ t }> / st
  | ST_Deref : forall t1 t1' st st',
         t1 / st --> t1' / st' ->
         <{ ! t1 }> / st --> <{ ! t1' }> / st'
  | ST_Assign : forall v l st st',
         value v ->
         store_assign st l v st' ->
         <{ (loc l) := v }> / st --> <{ unit }> / st'
  | ST_Assign1 : forall t1 t1' t2 st st',
         t1 / st --> t1' / st' ->
         <{ t1 := t2 }> / st --> <{ t1' := t2 }> / st'
  | ST_Assign2 : forall v1 t2 t2' st st',
         value v1 ->
         t2 / st --> t2' / st' ->
         <{ v1 := t2 }> / st --> <{ v1 := t2' }> / st'
  | ST_Free : forall st st' n,
      store_free st n st' ->
      <{free (loc n)}> / st --> <{unit}> / st'
  | ST_Free1 : forall t1 t1' st st',
         t1 / st --> t1' / st' ->
         <{ free t1 }> / st --> <{ free t1' }> / st'
where "t / st --> t' / st'" := (step (t,st) (t',st')).

Definition multi_step := Smallstep.multi step.

Notation "t / st -->* t' / st'" :=
  (multi_step (t, st) (t', st'))
       (at level 40, st at level 39, t' at level 39).

Lemma can_assign_empty_cell : forall st n t,
       first_empty_cell st n ->
       exists st', store_assign_new st n t st'.
Proof.
  intros.
  generalize dependent st.
  induction n.
  - intros.
    inversion H; subst; clear H.
    eexists. constructor.

  - intros.
    inversion H; subst; clear H.
    apply IHn in H2. destruct H2.
    eexists. constructor. eauto.
Qed.

Lemma assign_new_free_inv : forall st n t st',
       store_assign_new st n t st' ->
       store_free st' n st.
Proof.
  intros.
  generalize dependent st.
  generalize dependent st'.
  induction n.
  - intros. inversion H; subst. constructor.

  - intros. inversion H; subst; clear H.
    apply IHn in H2. constructor. auto.
Qed.

Lemma free_ref_noop : forall st t n,
       (* I could have proved it for arbitrary t, but
          it would require proving progress first. Therefore I will be assuming
          t is a value.
        *)
       value t ->
       (* ensure that st has an empty space *)
       first_empty_cell st n ->
       <{free (ref t)}> / st -->* <{unit}> / st.
Proof.
  intros.
  assert (first_empty_cell st n) by auto.
  apply can_assign_empty_cell with (t:=t) in H1. destruct H1.
  rename x into st'.
  assert (store_free st' n st) by eauto using assign_new_free_inv.

  eapply Smallstep.multi_step.
  eapply ST_Free1.
  apply ST_RefValue; eauto.

  eapply Smallstep.multi_step.
  eapply ST_Free; eauto.

  eapply Smallstep.multi_refl.
Qed.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

Require Export contact.
Require Export reflexion_plane.
Require Export similitudes_directes.
Set Implicit Arguments.
Unset Strict Implicit.
Hint Resolve translation_trivial rec_translation_vecteur: geo.

Lemma translation_isometrie :
 forall A A' B B' C C' : PO,
 B' = translation A A' B ->
 C' = translation A A' C -> distance B' C' = distance B C.
intros.
apply Rsqr_inj; auto with real geo.
unfold Rsqr in |- *.
repeat rewrite <- carre_scalaire_distance.
rewrite <-
 (translation_bipoint (I:=A) (J:=A') (A:=B) (A':=B') (B:=C) (B':=C'))
 ; auto.
Qed.

Lemma translation_conserve_orthogonalite :
 forall I J A A' B B' M M' : PO,
 A' = translation I J A ->
 B' = translation I J B ->
 M' = translation I J M ->
 orthogonal (vec A B) (vec A M) -> orthogonal (vec A' B') (vec A' M').
intros.
rewrite <-
 (translation_bipoint (I:=I) (J:=J) (A:=A) (A':=A') (B:=M) (B':=M'))
 ; auto.
rewrite <-
 (translation_bipoint (I:=I) (J:=J) (A:=A) (A':=A') (B:=B) (B':=B'))
 ; auto.
Qed.

Lemma translation_conserve_contact_cercle_droite :
 forall I J A A' B B' M M' O O' : PO,
 A' = translation I J A ->
 B' = translation I J B ->
 M' = translation I J M ->
 O' = translation I J O ->
 tangente_cercle O A B M -> tangente_cercle O' A' B' M'.
icercle.
rewrite
 (translation_isometrie (A:=I) (A':=J) (B:=O) (B':=O') (C:=A) (C':=A'))
 ; auto.
rewrite
 (translation_isometrie (A:=I) (A':=J) (B:=O) (B':=O') (C:=B) (C':=B'))
 ; auto.
apply
 (translation_conserve_orthogonalite (I:=I) (J:=J) (A:=B) (A':=B') (B:=M)
    (B':=M') (M:=O) (M':=O')); auto.
Qed.

Lemma translation_conserve_contact_cercle_cercle :
 forall I J A A' B B' K K' O O' : PO,
 O <> A ->
 K <> B ->
 A' = translation I J A ->
 B' = translation I J B ->
 K' = translation I J K ->
 O' = translation I J O ->
 cercles_tangents O A K B -> cercles_tangents O' A' K' B'.
intros.
elim
 cercles_tangents_tangente_commune with (O := O) (A := A) (O' := K) (A' := B);
 [ intros T H6; elim H6;
    [ intros M H7; elim H7;
       [ intros H8 H9; elim H9;
          [ intros H10 H11; try clear H9 H7 H6; try exact H10 ] ] ]
 | auto
 | auto
 | auto ].
elim existence_representant_vecteur with (A := T) (B := I) (C := J);
 [ intros T' H6; try clear existence_representant_vecteur; try exact H6 ].
elim existence_representant_vecteur with (A := M) (B := I) (C := J);
 [ intros M' H7; try clear existence_representant_vecteur; try exact H7 ].
assert (distance O' A' = distance O A).
rewrite <-
 (translation_isometrie (A:=I) (A':=J) (B:=O) (B':=O') (C:=A) (C':=A'))
 ; auto with geo.
assert (distance K' B' = distance K B).
rewrite <-
 (translation_isometrie (A:=I) (A':=J) (B:=K) (B':=K') (C:=B) (C':=B'))
 ; auto with geo.
assert (O' <> A').
apply (isometrie_distinct (A:=O) (B:=A) (A':=O') (B':=A')); auto.
assert (K' <> B').
apply (isometrie_distinct (A:=K) (B:=B) (A':=K') (B':=B')); auto.
assert (distance T' M' = distance T M).
rewrite <-
 (translation_isometrie (A:=I) (A':=J) (B:=T) (B':=T') (C:=M) (C':=M'))
 ; auto with geo.
assert (T' <> M').
apply (isometrie_distinct (A:=T) (B:=M) (A':=T') (B':=M')); auto.
apply tangente_commune_cercles_tangents with (B := T') (M := M'); auto.
apply translation_conserve_contact_cercle_droite with (1 := H1) (5 := H10);
 auto with geo.
apply translation_conserve_contact_cercle_droite with (1 := H2) (5 := H11);
 auto with geo.
Qed.

Lemma homothetie_conserve_orthogonalite :
 forall (k : R) (I A A' B B' M M' : PO),
 k <> 0 :>R ->
 A' = homothetie k I A :>PO ->
 B' = homothetie k I B :>PO ->
 M' = homothetie k I M :>PO ->
 orthogonal (vec A B) (vec A M) -> orthogonal (vec A' B') (vec A' M').
intros.
generalize (homothetie_bipoint (k:=k) (I:=I) (A:=A) (B:=B) (A':=A') (B':=B'));
 intros.
generalize (homothetie_bipoint (k:=k) (I:=I) (A:=A) (B:=M) (A':=A') (B':=M'));
 intros.
assert (orthogonal (vec A B) (vec A' M')).
apply ortho_sym; rewrite H5; auto with geo.
rewrite H4; auto with geo.
Qed.

Lemma homothetie_conserve_contact_cercle_droite :
 forall (k : R) (I A A' B B' M M' O O' : PO),
 k <> 0 :>R ->
 A' = homothetie k I A :>PO ->
 B' = homothetie k I B :>PO ->
 M' = homothetie k I M :>PO ->
 O' = homothetie k I O ->
 tangente_cercle O A B M -> tangente_cercle O' A' B' M'.
icercle.
rewrite (distance_homothetie (k:=k) (I:=I) (A:=O) (A':=O') (B:=A) (B':=A'));
 auto.
rewrite (distance_homothetie (k:=k) (I:=I) (A:=O) (A':=O') (B:=B) (B':=B'));
 auto.
rewrite H5; auto.
apply
 (homothetie_conserve_orthogonalite (k:=k) (I:=I) (A:=B) (A':=B') (B:=M)
    (B':=M') (M:=O) (M':=O')); auto.
Qed.

Lemma produit_distance_distinct :
 forall (A B C D : PO) (k : R),
 k <> 0 -> A <> B -> distance C D = k * distance A B -> C <> D.
intros.
contrapose H0.
assert (distance A B = 0); auto with geo.
replace (distance A B) with (/ k * distance C D).
rewrite H2.
replace (distance D D) with 0.
ring.
symmetry  in |- *; auto with geo.
rewrite H1.
field; auto.
Qed.

Lemma homothetie_conserve_contact_cercle_cercle :
 forall (k : R) (I J A A' B B' K K' O O' : PO),
 O <> A ->
 K <> B ->
 k <> 0 ->
 A' = homothetie k I A ->
 B' = homothetie k I B ->
 K' = homothetie k I K ->
 O' = homothetie k I O ->
 cercles_tangents O A K B -> cercles_tangents O' A' K' B'.
intros.
elim
 cercles_tangents_tangente_commune with (O := O) (A := A) (O' := K) (A' := B);
 [ intros T H7; elim H7;
    [ intros M H8; elim H8;
       [ intros H9 H10; elim H10;
          [ intros H11 H12; try clear H10 H8 H7; try exact H11 ] ] ]
 | auto
 | auto
 | auto ].
elim existence_homothetique with (k := k) (I := I) (A := T); [ intros T' H7 ].
elim existence_homothetique with (k := k) (I := I) (A := M); [ intros M' H8 ].
assert (O' <> A').
apply image_homothetie_distincts with (3 := H5) (4 := H2); auto.
assert (K' <> B').
apply image_homothetie_distincts with (3 := H4) (4 := H3); auto.
assert (T' <> M').
apply image_homothetie_distincts with (3 := H7) (4 := H8); auto.
apply tangente_commune_cercles_tangents with (B := T') (M := M'); auto.
apply homothetie_conserve_contact_cercle_droite with (2 := H2) (6 := H11);
 auto with geo.
apply homothetie_conserve_contact_cercle_droite with (2 := H3) (6 := H12);
 auto with geo.
Qed.

Lemma reflexion_conserve_orthogonalite :
 forall I J A A' B B' M M' : PO,
 I <> J ->
 A' = reflexion I J A :>PO ->
 B' = reflexion I J B :>PO ->
 M' = reflexion I J M :>PO ->
 orthogonal (vec A B) (vec A M) -> orthogonal (vec A' B') (vec A' M').
intros.
assert (distance A' B' = distance A B).
rewrite <-
 (reflexion_isometrie (A:=I) (B:=J) (M:=A) (M':=A') (N:=B) (N':=B'))
 ; auto with geo.
assert (distance A' M' = distance A M).
rewrite <-
 (reflexion_isometrie (A:=I) (B:=J) (M:=A) (M':=A') (N:=M) (N':=M'))
 ; auto with geo.
discrimine A B.
assert (distance A' B' = 0).
rewrite H4; rewrite H6; auto with geo.
assert (A' = B'); auto with geo.
rewrite H8.
VReplace (vec B' B') zero; auto with geo.
discrimine A M.
assert (distance A' M' = 0).
rewrite H5; rewrite H7; auto with geo.
assert (A' = M'); auto with geo.
rewrite H9.
VReplace (vec M' M') zero; auto with geo.
assert (~ alignes A B M); auto with geo.
assert (B <> M); auto with geo.
apply non_alignes_distincts2 with A; auto.
assert (cons_AV (vec A' B') (vec A' M') = opp (cons_AV (vec A B) (vec A M))).
apply reflexion_anti_deplacement with (A := I) (B := J); auto.
assert (double_AV (cons_AV (vec A M) (vec A B)) = image_angle pi).
apply orthogonal_angles; auto with geo.
apply angles_orthogonal.
apply (isometrie_distinct (A:=A) (B:=B) (A':=A') (B':=B')); auto.
apply (isometrie_distinct (A:=A) (B:=M) (A':=A') (B':=M')); auto.
rewrite H10.
rewrite def_opp; auto.
Qed.

Lemma reflexion_conserve_contact_cercle_droite :
 forall I J A A' B B' M M' O O' : PO,
 I <> J ->
 A' = reflexion I J A ->
 B' = reflexion I J B ->
 M' = reflexion I J M ->
 O' = reflexion I J O ->
 tangente_cercle O A B M -> tangente_cercle O' A' B' M'.
icercle.
rewrite <-
 (reflexion_isometrie (A:=I) (B:=J) (M:=O) (M':=O') (N:=A) (N':=A'))
 ; auto.
rewrite <-
 (reflexion_isometrie (A:=I) (B:=J) (M:=O) (M':=O') (N:=B) (N':=B'))
 ; auto.
apply
 (reflexion_conserve_orthogonalite (I:=I) (J:=J) (A:=B) (A':=B') (B:=M)
    (B':=M') (M:=O) (M':=O')); auto.
Qed.

Lemma reflexion_conserve_contact_cercle_cercle :
 forall I J A A' B B' K K' O O' : PO,
 I <> J ->
 O <> A ->
 K <> B ->
 A' = reflexion I J A ->
 B' = reflexion I J B ->
 K' = reflexion I J K ->
 O' = reflexion I J O ->
 cercles_tangents O A K B -> cercles_tangents O' A' K' B'.
intros.
elim
 cercles_tangents_tangente_commune with (O := O) (A := A) (O' := K) (A' := B);
 [ intros T H7; elim H7;
    [ intros M H8; elim H8;
       [ intros H9 H10; elim H10;
          [ intros H11 H12; try clear H10 H8 H7; try exact H11 ] ] ]
 | auto
 | auto
 | auto ].
elim existence_reflexion_AB with (A := I) (B := J) (M := T);
 [ intros T' H7; try clear existence_reflexion_AB; try exact H7 | auto ].
elim existence_reflexion_AB with (A := I) (B := J) (M := M);
 [ intros M' H8; try clear existence_reflexion_AB; try exact H7 | auto ].
assert (distance O' A' = distance O A).
rewrite <-
 (reflexion_isometrie (A:=I) (B:=J) (M:=O) (M':=O') (N:=A) (N':=A'))
 ; auto.
assert (O' <> A').
apply (isometrie_distinct (A:=O) (B:=A) (A':=O') (B':=A')); auto.
assert (distance K' B' = distance K B).
rewrite <-
 (reflexion_isometrie (A:=I) (B:=J) (M:=K) (M':=K') (N:=B) (N':=B'))
 ; auto.
assert (K' <> B').
apply (isometrie_distinct (A:=K) (B:=B) (A':=K') (B':=B')); auto.
assert (distance T' M' = distance T M).
rewrite <-
 (reflexion_isometrie (A:=I) (B:=J) (M:=T) (M':=T') (N:=M) (N':=M'))
 ; auto.
assert (T' <> M').
apply (isometrie_distinct (A:=T) (B:=M) (A':=T') (B':=M')); auto.
apply tangente_commune_cercles_tangents with (B := T') (M := M'); auto.
apply reflexion_conserve_contact_cercle_droite with (2 := H2) (6 := H11);
 auto with geo.
apply reflexion_conserve_contact_cercle_droite with (2 := H3) (6 := H12);
 auto with geo.
Qed.

Lemma rotation_conserve_orthogonalite :
 forall (I A B M A' B' M' : PO) (a : R),
 A' = rotation I a A ->
 B' = rotation I a B ->
 M' = rotation I a M ->
 orthogonal (vec A B) (vec A M) -> orthogonal (vec A' B') (vec A' M').
intros.
assert (distance A' B' = distance A B).
rewrite <- (rotation_isometrie (I:=I) (A:=A) (B:=B) (A':=A') (B':=B') (a:=a));
 auto with geo.
assert (distance A' M' = distance A M).
rewrite <- (rotation_isometrie (I:=I) (A:=A) (B:=M) (A':=A') (B':=M') (a:=a));
 auto with geo.
discrimine A B.
assert (distance A' B' = 0).
rewrite H3; rewrite H5; auto with geo.
assert (A' = B'); auto with geo.
rewrite H7.
VReplace (vec B' B') zero; auto with geo.
discrimine A M.
assert (distance A' M' = 0).
rewrite H4; rewrite H6; auto with geo.
assert (A' = M'); auto with geo.
rewrite H8.
VReplace (vec M' M') zero; auto with geo.
assert (cons_AV (vec A B) (vec A M) = cons_AV (vec A' B') (vec A' M')).
apply rotation_conserve_angle with (a := a) (I := I); auto.
assert (double_AV (cons_AV (vec A B) (vec A M)) = image_angle pi).
apply orthogonal_angles; auto with geo.
apply angles_orthogonal.
apply (isometrie_distinct (A:=A) (B:=B) (A':=A') (B':=B')); auto.
apply (isometrie_distinct (A:=A) (B:=M) (A':=A') (B':=M')); auto.
rewrite <- H7; auto.
Qed.

Lemma rotation_conserve_contact_cercle_droite :
 forall (I A A' B B' M M' O O' : PO) (a : R),
 A' = rotation I a A ->
 B' = rotation I a B ->
 M' = rotation I a M ->
 O' = rotation I a O ->
 tangente_cercle O A B M -> tangente_cercle O' A' B' M'.
icercle.
rewrite (rotation_isometrie (I:=I) (A:=O) (B:=A) (A':=O') (B':=A') (a:=a));
 auto.
rewrite (rotation_isometrie (I:=I) (A:=O) (B:=B) (A':=O') (B':=B') (a:=a));
 auto.
apply
 (rotation_conserve_orthogonalite (I:=I) (A:=B) (B:=M) (M:=O) (A':=B')
    (B':=M') (M':=O') (a:=a)); auto.
Qed.

Lemma rotation_conserve_contact_cercle_cercle :
 forall (I A A' B B' K K' O O' : PO) (a : R),
 O <> A ->
 K <> B ->
 A' = rotation I a A ->
 B' = rotation I a B ->
 K' = rotation I a K ->
 O' = rotation I a O ->
 cercles_tangents O A K B -> cercles_tangents O' A' K' B'.
intros.
elim
 cercles_tangents_tangente_commune with (O := O) (A := A) (O' := K) (A' := B);
 [ intros T H6; elim H6;
    [ intros M H7; elim H7;
       [ intros H8 H9; elim H9;
          [ intros H10 H11; try clear H9 H7 H6; try exact H10 ] ] ]
 | auto
 | auto
 | auto ].
elim existence_rotation_Ia with (I := I) (M := T) (a := a);
 [ intros T' H6; try clear existence_rotation_Ia; try exact H6 ].
elim existence_rotation_Ia with (I := I) (M := M) (a := a);
 [ intros M' H7; try clear existence_rotation_Ia; try exact H7 ].
assert (O' <> A').
apply (image_bipoint_distinct (I:=I) (A:=O) (B:=A) (A':=O') (B':=A') (a:=a));
 auto.
assert (K' <> B').
apply (image_bipoint_distinct (I:=I) (A:=K) (B:=B) (A':=K') (B':=B') (a:=a));
 auto.
assert (T' <> M').
apply (image_bipoint_distinct (I:=I) (A:=T) (B:=M) (A':=T') (B':=M') (a:=a));
 auto.
apply tangente_commune_cercles_tangents with (B := T') (M := M'); auto.
apply rotation_conserve_contact_cercle_droite with (1 := H1) (5 := H10);
 auto with geo.
apply rotation_conserve_contact_cercle_droite with (1 := H2) (5 := H11);
 auto with geo.
Qed.

Lemma similitude_conserve_orthogonalite :
 forall (I A B M A' B' M' : PO) (k a : R),
 k > 0 ->
 A' = similitude I k a A ->
 B' = similitude I k a B ->
 M' = similitude I k a M ->
 orthogonal (vec A B) (vec A M) -> orthogonal (vec A' B') (vec A' M').
intros.
assert (distance A' B' = k * distance A B).
rewrite <-
 (distance_similitude (k:=k) (a:=a) (I:=I) (A:=A) (B:=B) (A':=A') (B':=B'))
 ; auto with geo.
assert (distance A' M' = k * distance A M).
rewrite <-
 (distance_similitude (k:=k) (a:=a) (I:=I) (A:=A) (B:=M) (A':=A') (B':=M'))
 ; auto with geo.
discrimine A B.
assert (distance A' B' = 0).
rewrite H4; rewrite H6.
replace (distance B B) with 0.
ring.
symmetry  in |- *; auto with geo.
assert (A' = B'); auto with geo.
rewrite H8.
VReplace (vec B' B') zero; auto with geo.
discrimine A M.
assert (distance A' M' = 0).
rewrite H5; rewrite H7.
replace (distance M M) with 0.
ring.
symmetry  in |- *; auto with geo.
assert (A' = M'); auto with geo.
rewrite H9.
VReplace (vec M' M') zero; auto with geo.
assert (cons_AV (vec A B) (vec A M) = cons_AV (vec A' B') (vec A' M')).
apply similitude_conserve_angle with (a := a) (k := k) (I := I); auto.
assert (double_AV (cons_AV (vec A B) (vec A M)) = image_angle pi).
apply orthogonal_angles; auto with geo.
assert (k <> 0); auto with real.
apply angles_orthogonal.
apply produit_distance_distinct with (3 := H4); auto.
apply produit_distance_distinct with (3 := H5); auto.
rewrite <- H8; auto.
Qed.

Lemma similitude_conserve_contact_cercle_droite :
 forall (I A B M A' B' M' O O' : PO) (k a : R),
 k > 0 ->
 A' = similitude I k a A ->
 B' = similitude I k a B ->
 M' = similitude I k a M ->
 O' = similitude I k a O ->
 tangente_cercle O A B M -> tangente_cercle O' A' B' M'.
icercle.
rewrite
 (distance_similitude (k:=k) (a:=a) (I:=I) (A:=O) (B:=A) (A':=O') (B':=A'))
 ; auto.
rewrite
 (distance_similitude (k:=k) (a:=a) (I:=I) (A:=O) (B:=B) (A':=O') (B':=B'))
 ; auto.
rewrite H5; auto.
apply
 (similitude_conserve_orthogonalite (I:=I) (A:=B) (B:=M) (M:=O) (A':=B')
    (B':=M') (M':=O') (k:=k) (a:=a)); auto.
Qed.

Lemma similitude_conserve_contact_cercle_cercle :
 forall (I A A' B B' K K' O O' : PO) (k a : R),
 k > 0 ->
 O <> A ->
 K <> B ->
 A' = similitude I k a A ->
 B' = similitude I k a B ->
 K' = similitude I k a K ->
 O' = similitude I k a O ->
 cercles_tangents O A K B -> cercles_tangents O' A' K' B'.
intros.
elim
 cercles_tangents_tangente_commune with (O := O) (A := A) (O' := K) (A' := B);
 [ intros T H7; elim H7;
    [ intros M H8; elim H8;
       [ intros H9 H10; elim H10;
          [ intros H11 H12;
             try clear H10 H8 H7 cercles_tangents_tangente_commune;
             try exact H11 ] ] ]
 | auto
 | auto
 | auto ].
elim existence_similitude_Ika with (I := I) (M := T) (k := k) (a := a);
 [ intros T' H13; try clear existence_similitude_Ika; try exact H13 | auto ].
elim existence_similitude_Ika with (I := I) (M := M) (k := k) (a := a);
 [ intros M' H14; try clear existence_similitude_Ika; try exact H14 | auto ].
assert (distance O' A' = k * distance O A).
rewrite <-
 (distance_similitude (k:=k) (a:=a) (I:=I) (A:=O) (B:=A) (A':=O') (B':=A'))
 ; auto with geo.
assert (distance K' B' = k * distance K B).
rewrite <-
 (distance_similitude (k:=k) (a:=a) (I:=I) (A:=K) (B:=B) (A':=K') (B':=B'))
 ; auto with geo.
assert (distance T' M' = k * distance T M).
rewrite <-
 (distance_similitude (k:=k) (a:=a) (I:=I) (A:=T) (B:=M) (A':=T') (B':=M'))
 ; auto with geo.
assert (k <> 0); auto with real.
assert (O' <> A').
apply produit_distance_distinct with (3 := H15); auto.
assert (K' <> B').
apply produit_distance_distinct with (3 := H16); auto.
assert (T' <> M').
apply produit_distance_distinct with (3 := H17); auto.
apply tangente_commune_cercles_tangents with (B := T') (M := M'); auto.
apply similitude_conserve_contact_cercle_droite with (2 := H2) (6 := H11);
 auto with geo.
apply similitude_conserve_contact_cercle_droite with (2 := H3) (6 := H12);
 auto with geo.
Qed.