Require Import vellvm.
Require Import memory_sim.
Require Import sflib.

Ltac unfold_blk2GV := unfold blk2GV, ptr2GV, val2GV.

Lemma simpl_blk2GV: forall td mb,
  blk2GV td mb =
  ((Vptr mb (Int.repr 31 0),
    AST.Mint (Size.mul Size.Eight (getPointerSize td) - 1)) :: nil).
Proof.
  intros. unfold_blk2GV. auto.
Qed.

Module MemProps.

(*****************************************************************)
(* We assume blocks smaller than maxb are allocated for globals. *)
Fixpoint wf_global (maxb:Values.block) (gv:GenericValue) : Prop :=
match gv with
| nil => True
| (Vptr b _,_)::gv' => (b <= maxb)%positive /\ wf_global maxb gv'
| _::gv' => wf_global maxb gv'
end.

Fixpoint wf_global_list maxb (gl:GVMap) : Prop :=
match gl with
| nil => True
| (_,gv)::gl' => wf_global maxb gv /\ wf_global_list maxb gl'
end.

(* maxb must be non-negative. *)
Definition wf_globals maxb (gl:GVMap) : Prop :=
(xH <= maxb)%positive /\ wf_global_list maxb gl.

(*****************************************************************)
(* Two values are not aliased if they do not have pointers in the same block. *)
Fixpoint no_alias_with_blk (gvs:GenericValue) (blk:Values.block) : Prop :=
match gvs with
| nil => True
| (Vptr b _,_)::gvs' => b <> blk /\ no_alias_with_blk gvs' blk
| _::gvs' => no_alias_with_blk gvs' blk
end.

Fixpoint no_alias (gvs1 gvs2:GenericValue) : Prop :=
match gvs2 with
| nil => True
| (Vptr b _,_)::gvs2' => no_alias_with_blk gvs1 b /\ no_alias gvs1 gvs2'
| _::gvs2' => no_alias gvs1 gvs2'
end.

(*****************************************************************)
(* bound is the maximal block allocated so far. A pointer is valid if
   it only uses blocks smaller than bound. *)
Fixpoint valid_ptrs (bound:Values.block) (gvs:GenericValue): Prop :=
match gvs with
| nil => True
| (Vptr blk _,_)::gvs' => (blk < bound)%positive /\ valid_ptrs bound gvs'
| _::gvs' => valid_ptrs bound gvs'
end.

(*****************************************************************)
(* pointers in locals, memory and allocation lists must be valid. *)
Definition wf_lc M lc : Prop :=
forall id0 gvs,
  lookupAL _ lc id0 = Some gvs -> valid_ptrs (Mem.nextblock M) gvs.

Definition wf_Mem maxb (td:targetdata) (M:mem) : Prop :=
(forall gptr ty al gvs,
  mload td M gptr ty al = Some gvs -> valid_ptrs (Mem.nextblock M) gvs) /\
(maxb < Mem.nextblock M)%positive.

(*****************************************************************)
(* Check if gv contains pointers *)
Fixpoint no_embedded_ptrs (gvs:GenericValue): Prop :=
match gvs with
| nil => True
| (Vptr _ _,_)::gvs' => False
| _::gvs' => no_embedded_ptrs gvs'
end.

(*****************************************************************)
Definition encode_decode_ident_prop
  (M:mem) (b:Values.block) (ofs:Z) (chunk:AST.memory_chunk) : Prop :=
forall bs,
  bs = Mem.getN (size_chunk_nat chunk) ofs (Maps.PMap.get b (Mem.mem_contents M)) ->
  bs = encode_val chunk (decode_val chunk bs).

Fixpoint encode_decode_ident_aux (M:mem) (mc:list AST.memory_chunk) b ofs
  : Prop :=
match mc with
| nil => True
| c::mc' => encode_decode_ident_prop M b ofs c /\
            encode_decode_ident_aux M mc' b (ofs+size_chunk c)%Z
end.

Definition encode_decode_ident
  (TD:TargetData) (M:mem) (ptr:mptr) (t:typ) (a:align) : Prop :=
match GV2ptr TD (getPointerSize TD) ptr with
| Some (Vptr b ofs) =>
  match flatten_typ TD t with
  | Some mc => encode_decode_ident_aux M mc b (Int.signed 31 ofs)
  | _ => False
  end
| _ => False
end.

Axiom zeroconst2GV_no_ptr: forall
      TD t g
      (ZCGV: zeroconst2GV TD t = Some g)
  ,
    <<NOPTR: MemProps.no_embedded_ptrs g>>
.

(*****************************************************************)
(* Properties of no_embedded_ptrs. *)
Lemma mc2undefs__no_embedded_ptrs: forall l0,
  no_embedded_ptrs (mc2undefs l0).
Proof.
  induction l0; simpl; auto.
Qed.

Lemma undef__no_embedded_ptrs: forall g td t1
  (Hc2g : ret g = gundef td t1), no_embedded_ptrs g.
Proof.
  unfold gundef. intros.
  inv_mbind'. simpl. apply mc2undefs__no_embedded_ptrs.
Qed.

Lemma no_embedded_ptrs__no_alias_with_blk: forall b2 gvs1,
  no_embedded_ptrs gvs1 -> no_alias_with_blk gvs1 b2.
Proof.
  induction gvs1 as [|[]]; simpl; intros; auto.
    destruct v; auto. inv H.
Qed.

Lemma no_embedded_ptrs__no_alias: forall gvs1 gvs2,
  no_embedded_ptrs gvs1 -> no_alias gvs1 gvs2.
Proof.
  induction gvs2 as [|[]]; simpl; intros; auto.
    destruct v; auto.
    split; auto using no_embedded_ptrs__no_alias_with_blk.
Qed.

Lemma no_embedded_ptrs__valid_ptrs: forall bd gvs,
  no_embedded_ptrs gvs -> valid_ptrs bd gvs.
Proof.
  induction gvs as [|[]]; simpl; intros; auto.
    destruct v; auto.
      inversion H.
Qed.

Lemma mtrunc_preserves_no_embedded_ptrs: forall td top t1 t2 gv gv',
  mtrunc td top t1 t2 gv = Some gv' -> no_embedded_ptrs gv'.
Proof.
  intros.
  unfold mtrunc in H.
  remember (GV2val td gv) as R.
  destruct R; eauto using undef__no_embedded_ptrs.
  destruct v; eauto using undef__no_embedded_ptrs.
    destruct_typ t1; eauto using undef__no_embedded_ptrs.
      destruct_typ t2; eauto using undef__no_embedded_ptrs.
        inv H. destruct (le_lt_dec wz (s1-1)); simpl; auto.

    destruct_typ t1; eauto using undef__no_embedded_ptrs.
      destruct_typ t2; eauto using undef__no_embedded_ptrs.
      destruct (floating_point_order f1 f0); tinv H.
      destruct f0; inv H; unfold val2GV; simpl; auto; eauto using undef__no_embedded_ptrs.
      eauto using undef__no_embedded_ptrs.

    destruct_typ t1; eauto using undef__no_embedded_ptrs.
      destruct_typ t2; eauto using undef__no_embedded_ptrs.
Qed.

Lemma mext_preserves_no_embedded_ptrs: forall td eop t1 t2 gv gv',
  mext td eop t1 t2 gv = Some gv' -> no_embedded_ptrs gv'.
Proof.
  {
    ii. unfold mext in *.
    des_ifs; eauto using undef__no_embedded_ptrs.
  }
  (* intros. *)
  (* unfold mext in H. *)
  (* remember (GV2val td gv) as R. *)
  (* destruct t1; tinv H. *)
  (*   destruct t2; tinv H. *)
  (*   destruct R; eauto using undef__no_embedded_ptrs. *)
  (*   destruct v; eauto using undef__no_embedded_ptrs. *)
  (*   destruct eop; inv H; simpl; auto. *)

  (*   destruct_typ t2; tinv H. *)
  (*   match goal with *)
  (*     | H : (if ?t then _ else _ ) = _ |- _ => destruct t; tinv H *)
  (*   end. *)
  (*   destruct R; eauto using undef__no_embedded_ptrs. *)
  (*   destruct v; eauto using undef__no_embedded_ptrs. *)
  (*   destruct eop; tinv H; simpl; auto. *)
  (*   destruct f; inv H; unfold val2GV; simpl; auto. *)
Qed.

Lemma nonptr_no_embedded_ptrs: forall v t td,
  (forall b ofs, v <> Vptr b ofs) -> no_embedded_ptrs (val2GV td v t).
Proof.
  intros.
  destruct v; simpl; auto.
    assert (H1:=@H b i0). congruence.
Qed.

Lemma micmp_int_preserves_no_embedded_ptrs: forall td cop gv1 gv2 gv',
  micmp_int td cop gv1 gv2 = Some gv' -> no_embedded_ptrs gv'.
Proof.
  intros.
  unfold micmp_int in H.
  destruct (GV2val td gv1); eauto using undef__no_embedded_ptrs.
  destruct v; eauto using undef__no_embedded_ptrs.
  destruct (GV2val td gv2); eauto using undef__no_embedded_ptrs.
  destruct v; eauto using undef__no_embedded_ptrs.
Opaque Val.cmp Val.cmpu.
  destruct cop; inv H;
    apply nonptr_no_embedded_ptrs;
      try solve [auto | apply cmp_isnt_ptr | apply cmpu_int_isnt_ptr].
Transparent Val.cmp Val.cmpu Val.cmpu_int.
Qed.

Lemma mbop_preserves_no_embedded_ptrs: forall td bop0 sz0 gv1 gv2 gv3,
  mbop td bop0 sz0 gv1 gv2 = Some gv3 -> no_embedded_ptrs gv3.
Proof.
  intros.
  unfold mbop in H.
  destruct (GV2val td gv1); eauto using undef__no_embedded_ptrs.
  destruct v; eauto using undef__no_embedded_ptrs.
  destruct (GV2val td gv2); eauto using undef__no_embedded_ptrs.
  destruct v; eauto using undef__no_embedded_ptrs.
  destruct (eq_nat_dec (wz + 1) (Size.to_nat sz0));
    eauto using undef__no_embedded_ptrs.
  destruct bop0; inv H;
    try apply nonptr_no_embedded_ptrs;
      try solve
        [apply add_isnt_ptr | apply sub_isnt_ptr | apply mul_isnt_ptr |
         apply shl_isnt_ptr | apply shr_isnt_ptr | apply and_isnt_ptr |
         apply or_isnt_ptr | apply xor_isnt_ptr |
         (destruct (eq_nat_dec _ _); subst; eauto using undef__no_embedded_ptrs;
           try match goal with
             | _: context[if ?s then _ else _] |- _ => destruct s end
           ; subst; inv H1; eauto using undef__no_embedded_ptrs
           ; apply nonptr_no_embedded_ptrs; congruence)].
Qed.

Lemma mfbop_preserves_no_embedded_ptrs: forall td fbop0 fp0 gv1 gv2 gv3,
  mfbop td fbop0 fp0 gv1 gv2 = Some gv3 -> no_embedded_ptrs gv3.
Proof.
  intros.
  unfold mfbop in H.
  destruct (GV2val td gv1); eauto using undef__no_embedded_ptrs.
  destruct v; eauto using undef__no_embedded_ptrs.
  destruct (GV2val td gv2); eauto using undef__no_embedded_ptrs.
  destruct v; eauto using undef__no_embedded_ptrs.
  destruct fp0; tinv H; destruct fbop0; inv H; simpl; eauto using undef__no_embedded_ptrs.
  destruct (GV2val td gv2); try destruct v; eauto using undef__no_embedded_ptrs.
  destruct fp0; tinv H; destruct fbop0; inv H; simpl; eauto using undef__no_embedded_ptrs.
Qed.

(*****************************************************************)
(* Inversion *)
Lemma mbitcast_inv: forall t1 t2 gv1 gv2,
  mbitcast t1 gv1 t2 = ret gv2 -> gv1 = gv2.
Proof.
  intros.
  unfold mbitcast in H.
  destruct t1; tinv H.
    destruct t2; inv H; auto.
    destruct t2; inv H; auto.
Qed.

Lemma mcast_inv: forall td cop t1 t2 gv1 gv2,
  mcast td cop t1 t2 gv1 = ret gv2 -> gv2 = gv1 \/ gundef td t2 = ret gv2.
Proof.
  intros.
  unfold mcast in H.
  destruct cop; auto;
    try
    match goal with
    | H : mbitcast _ _ _ = ret _ |- _ => apply mbitcast_inv in H; subst; auto
    end.
Qed.

Lemma GV2ptr_inv: forall g1 td v,
  ret v = GV2ptr td (getPointerSize td) g1 ->
  exists b, exists ofs, exists m, g1 = (Vptr b ofs, m)::nil /\ v = Vptr b ofs.
Proof.
  intros.
  unfold GV2ptr in H.
  destruct g1 as [|[]]; tinv H.
  destruct v0; tinv H.
  destruct g1 as [|[]]; inv H.
  unfold ptr2GV. unfold val2GV. eauto.
Qed.

Lemma mgep_inv: forall td v1 t1 l1 v2,
  ret v2 = mgep td t1 v1 l1 ->
  exists b, exists ofs1, exists ofs2, v1 = Vptr b ofs1 /\ v2 = Vptr b ofs2.
Proof.
  intros.
  unfold mgep in *.
  destruct v1; tinv H.
  destruct l1; tinv H.
  destruct (mgetoffset td (typ_array 0%nat t1) (z :: l1)) as [[]|]; inv H.
  eauto.
Qed.

(*****************************************************************)
(* Properties of no_alias. *)

Lemma no_alias_nil: forall g, no_alias nil g.
Proof.
  induction g; simpl; intros; auto.
    destruct a.
    destruct v; auto.
Qed.

Lemma no_alias_with_blk_split: forall g2 b g1,
  no_alias_with_blk (g1++g2) b ->
  no_alias_with_blk g1 b /\ no_alias_with_blk g2 b.
Proof.
  induction g1 as [|[]]; simpl; intros; auto.
    destruct v; auto.
    destruct H. apply IHg1 in H0. destruct H0. split; auto.
Qed.

Lemma no_alias_split: forall g2 g1 g,
  no_alias (g1++g2) g -> no_alias g1 g /\ no_alias g2 g.
Proof.
  induction g as [|[]]; simpl; intros; auto.
    destruct v; auto.

    destruct H. apply IHg in H0. destruct H0.
    apply no_alias_with_blk_split in H. destruct H.
    repeat split; auto.
Qed.

Lemma ptr_no_alias__no_alias_with_blk : forall b i0 m gvs2,
  no_alias [(Vptr b i0, m)] gvs2 -> no_alias_with_blk gvs2 b.
Proof.
  induction gvs2 as [|[]]; simpl; intros; auto.
    destruct v; auto.
    destruct H. destruct H.
    split; auto.
Qed.

Lemma no_alias_sym: forall gvs2 gvs1, no_alias gvs1 gvs2 -> no_alias gvs2 gvs1.
Proof.
  induction gvs1 as [|[]]; simpl; intros; auto.
    simpl_env in H.
    apply no_alias_split in H.
    destruct H as [H1 H2].
    destruct v; auto.
    split; auto.
      apply ptr_no_alias__no_alias_with_blk in H1; auto.
Qed.

(*****************************************************************)
Lemma uninits_valid_ptrs: forall bd n, valid_ptrs bd (uninits n).
Proof.
  intros.
  induction n; simpl; auto.
Qed.

Lemma valid_ptrs_app: forall bd g2 g1,
  valid_ptrs bd g1 -> valid_ptrs bd g2 -> valid_ptrs bd (g1++g2).
Proof.
  induction g1 as [|[]]; simpl; intros; auto.
    destruct v; auto.
    destruct H.
    split; auto.
Qed.

Lemma mtrunc_preserves_valid_ptrs: forall td top t1 t2 gv gv' bd,
  mtrunc td top t1 t2 gv = Some gv' -> valid_ptrs bd gv'.
Proof.
  intros.
  apply no_embedded_ptrs__valid_ptrs.
  apply mtrunc_preserves_no_embedded_ptrs in H; auto.
Qed.

Lemma mext_preserves_valid_ptrs: forall td eop t1 t2 gv gv' bd,
  mext td eop t1 t2 gv = Some gv' -> valid_ptrs bd gv'.
Proof.
  intros.
  apply no_embedded_ptrs__valid_ptrs.
  apply mext_preserves_no_embedded_ptrs in H; auto.
Qed.

Lemma mc2undefs_valid_ptrs: forall blk l0, valid_ptrs blk (mc2undefs l0).
Proof. induction l0; simpl; auto. Qed.

Lemma undef_valid_ptrs: forall g td t1 blk
  (Hc2g : ret g = gundef td t1), valid_ptrs blk g.
Proof.
  unfold gundef. intros.
  inv_mbind'. simpl. apply mc2undefs_valid_ptrs.
Qed.

Lemma mcast_preserves_valid_ptrs: forall td cop t1 t2 gv gv' bd,
  mcast td cop t1 t2 gv = Some gv' -> valid_ptrs bd gv -> valid_ptrs bd gv'.
Proof.
  intros.
  apply mcast_inv in H.
  destruct H as [H | H]; subst; eauto using undef_valid_ptrs.
Qed.

Lemma GV2ptr_preserves_valid_ptrs: forall bd g1 td v,
  valid_ptrs bd g1 ->
  ret v = GV2ptr td (getPointerSize td) g1 ->
  valid_ptrs bd (ptr2GV td v).
Proof.
  intros. apply GV2ptr_inv in H0. destruct H0 as [b [ofs [m [J1 J2]]]]; subst.
  unfold ptr2GV. unfold val2GV. simpl in *. auto.
Qed.

Lemma mgep_preserves_valid_ptrs: forall td v t1 l1 v0 bd,
  valid_ptrs bd (ptr2GV td v) ->
  ret v0 = mgep td t1 v l1 ->
  valid_ptrs bd (ptr2GV td v0).
Proof.
  intros.
  apply mgep_inv in H0. destruct H0 as [b [ofs1 [ofs2 [J1 J2]]]]; subst.
  simpl in *. auto.
Qed.

Lemma micmp_int_preserves_valid_ptrs: forall td cop gv1 gv2 bd gv',
  micmp_int td cop gv1 gv2 = Some gv' -> valid_ptrs bd gv'.
Proof.
  intros.
  apply no_embedded_ptrs__valid_ptrs.
  apply micmp_int_preserves_no_embedded_ptrs in H; auto.
Qed.

Lemma micmp_preserves_valid_ptrs: forall td cop t1 gv1 gv2 gv' bd,
  micmp td cop t1 gv1 gv2 = Some gv' -> valid_ptrs bd gv'.
Proof.
  intros.
  unfold micmp in H.
  destruct t1; tinv H; eauto using undef_valid_ptrs.
    eapply micmp_int_preserves_valid_ptrs; eauto.
Qed.

Lemma cmpf_non_ptr
      cmp v1 v2
  :
    forall b ofs, Val.cmpf cmp v1 v2 <> Vptr b ofs
.
Proof.
  i. compute; des_ifs.
Qed.

Lemma mfcmp_preserves_valid_ptrs: forall td fop fp gv1 gv2 gv' bd,
  mfcmp td fop fp gv1 gv2 = Some gv' -> valid_ptrs bd gv'.
Proof.
  intros.
  unfold mfcmp in H.
  destruct (GV2val td gv1); eauto using undef_valid_ptrs.
  destruct v; eauto using undef_valid_ptrs.
  destruct (GV2val td gv2); eauto using undef_valid_ptrs.
  destruct v; eauto using undef_valid_ptrs.
  apply no_embedded_ptrs__valid_ptrs.
  des_ifs; try (by (eapply nonptr_no_embedded_ptrs; eapply cmpf_non_ptr));
    try (by compute in H; des_ifs).
  (* destruct fp; tinv H; *)
  (*   destruct fop; inv H; apply nonptr_no_embedded_ptrs; *)
  (*     try solve [auto | apply Vfalse_isnt_ptr | apply Vtrue_isnt_ptr | *)
  (*                apply val_of_bool_isnt_ptr]. *)
Qed.

Lemma splitGenericValue_preserves_valid_ptrs: forall bd g0 z0 g1 g2,
  valid_ptrs bd g0 ->
  ret (g1, g2) = splitGenericValue g0 z0 ->
  valid_ptrs bd g1 /\ valid_ptrs bd g2.
Proof.
  induction g0 as [|[]]; simpl; intros.
    destruct (zeq z0 0).
      inv H0. auto.
      destruct (zlt z0 0); tinv H0.

    destruct (zeq z0 0).
      inv H0. simpl. auto.

      destruct (zlt z0 0); tinv H0.
      inv_mbind'. inv H2.
      simpl_env in H.
      assert (valid_ptrs bd [(v,m)] /\ valid_ptrs bd g0) as J.
        simpl.
        destruct v; auto.
          destruct H; auto.
      destruct J as [J1 J2].
      apply IHg0 in HeqR; auto.
      destruct HeqR.
      split; auto.
        simpl_env.
        apply valid_ptrs_app; auto.
Qed.

Lemma extractGenericValue_preserves_valid_ptrs: forall td g1 t1 g0 bd l0,
  valid_ptrs bd g0 -> ret g1 = extractGenericValue td t1 g0 l0 ->
  valid_ptrs bd g1.
Proof.
  intros.
  unfold extractGenericValue in *.
  inv_mbind'.
  remember (mget td g0 z t) as R.
  destruct R; eauto using undef_valid_ptrs.
  inv H1.
  unfold mget in HeqR1.
  destruct (getTypeStoreSize td t); tinv HeqR1.
  simpl in HeqR1.
  inv_mbind'. inv H2.
  eapply splitGenericValue_preserves_valid_ptrs in HeqR2; eauto.
  destruct HeqR2.
  eapply splitGenericValue_preserves_valid_ptrs in HeqR1; eauto.
  destruct HeqR1; auto.
  destruct_if; eauto.
Qed.

Lemma insertGenericValue_preserves_valid_ptrs: forall td t1 t2 g0 g1 g2 l0 bd,
  valid_ptrs bd g0 -> valid_ptrs bd g1 ->
  ret g2 = insertGenericValue td t1 g0 l0 t2 g1 -> valid_ptrs bd g2.
Proof.
  intros.
  unfold insertGenericValue in *.
  inv_mbind'.
  remember (mset td g0 z t2 g1) as R.
  destruct R; eauto using undef_valid_ptrs.
  inv H2.
  unfold mset in HeqR1.
  destruct (getTypeStoreSize td t2); tinv HeqR1.
  simpl in HeqR1.
  destruct (n =n= length g1); tinv HeqR1.
  inv_mbind'. inv H3.
  eapply splitGenericValue_preserves_valid_ptrs in HeqR2; eauto.
  destruct HeqR2.
  eapply splitGenericValue_preserves_valid_ptrs in HeqR1; eauto.
  destruct HeqR1.
  destruct_if; eauto.
  repeat apply valid_ptrs_app; auto.
Qed.

Lemma mbop_preserves_valid_ptrs: forall td bop0 sz0 gv1 gv2 gv3 bd,
  mbop td bop0 sz0 gv1 gv2 = Some gv3 ->
  valid_ptrs bd gv3.
Proof.
  intros.
  apply no_embedded_ptrs__valid_ptrs.
  apply mbop_preserves_no_embedded_ptrs in H; auto.
Qed.

Lemma mfbop_preserves_valid_ptrs: forall td fbop0 fp0 gv1 gv2 gv3 bd,
  mfbop td fbop0 fp0 gv1 gv2 = Some gv3 -> valid_ptrs bd gv3.
Proof.
  intros.
  apply no_embedded_ptrs__valid_ptrs.
  apply mfbop_preserves_no_embedded_ptrs in H; auto.
Qed.

Lemma valid_ptrs__trans: forall bound1 bound2 gv,
  valid_ptrs bound1 gv -> (bound1 <= bound2)%positive -> valid_ptrs bound2 gv.
Proof.
  induction gv as [|[]]; simpl; intros; auto.
    destruct v; auto.
      destruct H. split; auto. eapply Pos.lt_le_trans; eauto.
Qed.

Lemma in_valid_ptrs: forall bd m b ofs gvs,
  valid_ptrs bd gvs -> In (Vptr b ofs, m) gvs -> (b < bd)%positive.
Proof.
  induction gvs as [|[]]; simpl; intros.
    inv H0.

    destruct H0 as [H0 | H0].
      inv H0.
      destruct H; auto.

      destruct v; eauto.
      destruct H; eauto.
Qed.

Lemma valid_ptrs_overlap: forall gvs1 gvs2 bd gvs0,
  valid_ptrs bd gvs1 ->
  valid_ptrs bd gvs2 ->
  (forall (v : val) (m : AST.memory_chunk),
       In (v, m) gvs0 ->
       In (v, m) gvs2 \/
       (forall (b0 : Values.block) (ofs0 : int32),
        v = Vptr b0 ofs0 -> In (v, m) gvs1)) ->
  valid_ptrs bd gvs0.
Proof.
  induction gvs0 as [|[]]; simpl; intros; auto.
    destruct v; eauto.
    edestruct H1 as [J1 | J1]; eauto.
      split; eauto.
      eapply in_valid_ptrs in J1; eauto.

      split; eauto.
      eapply in_valid_ptrs in H; eauto.
Qed.

Lemma valid_ptrs__no_alias__fresh_ptr: forall bound TD mb (Hbd: (bound <= mb)%positive)
  gvs, valid_ptrs bound gvs ->
  no_alias gvs (blk2GV TD mb).
Proof.
Local Opaque no_alias.
  induction gvs as [|[]]; simpl; intros.
    apply no_alias_nil.

    destruct v; auto.
    destruct H.
    apply IHgvs in H0. rewrite simpl_blk2GV in *. simpl in *.
    destruct H0.
    repeat split; auto.
      intro J. subst. contradict H; apply Pos.le_nlt; auto.
Transparent no_alias.
Qed.

Lemma undefs_valid_ptrs: forall bd gvs1
  (Hc2g : forall v m, In (v, m) gvs1 -> v = Vundef),
  valid_ptrs bd gvs1.
Proof.
  induction gvs1 as [|[]]; simpl; intros; auto.
    destruct v; eauto.
    assert ((Vptr b i0, m) = (Vptr b i0, m) \/ In (Vptr b i0, m) gvs1) as J.
      auto.
    apply Hc2g in J. congruence.
Qed.

Lemma updateAddAL__wf_lc: forall gv3 Mem0 lc id0
  (Hwfgv: valid_ptrs (Mem.nextblock Mem0) gv3) (Hwflc: wf_lc Mem0 lc),
  wf_lc Mem0 (updateAddAL GenericValue lc id0 gv3).
Proof.
  intros. unfold wf_lc in *. intros.
  destruct (id_dec id0 id1); subst.
    rewrite lookupAL_updateAddAL_eq in H. inv H. eauto.

    rewrite <- lookupAL_updateAddAL_neq in H; auto.
    eapply Hwflc; eauto.
Qed.

(*****************************************************************)
(* Properties of free. *)
Lemma nextblock_free: forall TD M gv M',
  free TD M gv = ret M' -> Mem.nextblock M = Mem.nextblock M'.
Proof.
  intros.
  apply free_inv in H.
  destruct H as [blk' [ofs' [hi [lo [J4 [J5 [J6 J7]]]]]]].
  apply Mem.nextblock_free in J7. auto.
Qed.

Lemma free_preserves_mload_aux_inv: forall blk lo hi b Mem Mem'
  (Hfree:Mem.free Mem blk lo hi = ret Mem') mc ofs gvsa,
  mload_aux Mem' mc b ofs = ret gvsa ->
  mload_aux Mem mc b ofs = ret gvsa.
Proof.
  induction mc; simpl; intros; auto.
    inv_mbind'. symmetry in HeqR0.
    apply IHmc in HeqR0.
    rewrite HeqR0.
    erewrite <- Mem.load_free; eauto.
      rewrite <- HeqR. auto.
      eapply Mem.load_free'; eauto.
Qed.

Lemma free_preserves_mload_inv: forall TD Mem' gptr ty al gvsa Mem mptr0
  (H1 : mload TD Mem' gptr ty al = ret gvsa)
  (H2 : free TD Mem mptr0 = ret Mem'),
  mload TD Mem gptr ty al = ret gvsa.
Proof.
  intros.
  apply mload_inv in H1.
  destruct H1 as [b [ofs [m [mc [J1 [J2 J3]]]]]]; subst.
  unfold mload. simpl. rewrite J2.
  apply free_inv in H2.
  destruct H2 as [blk' [ofs' [hi [lo [J4 [J5 [J6 J7]]]]]]].
  eapply free_preserves_mload_aux_inv; eauto.
Qed.

Lemma free_preserves_wf_lc: forall TD Mem' Mem mptr0
  (H2 : free TD Mem mptr0 = ret Mem') lc
  (Hwf: wf_lc Mem lc),
  wf_lc Mem' lc.
Proof.
  unfold wf_lc.
  intros.
  apply Hwf in H.
  apply free_inv in H2.
  destruct H2 as [blk' [ofs' [hi [lo [J4 [J5 [J6 J7]]]]]]].
  erewrite Mem.nextblock_free; eauto.
Qed.

Lemma free_preserves_mload_aux: forall Mem blk lo hi Mem' b
  (Hfree: Mem.free Mem blk lo hi = ret Mem') (Hneq: blk <> b) mc ofs gv,
  mload_aux Mem mc b ofs = ret gv ->
  mload_aux Mem' mc b ofs = ret gv.
Proof.
  induction mc; simpl; intros; auto.
    inv_mbind'. symmetry in HeqR0.
    apply IHmc in HeqR0.
    rewrite HeqR0.
    erewrite Mem.load_free; eauto.
      rewrite <- HeqR. auto.
Qed.

Lemma free_preserves_mload: forall TD Mem Mem' t al gv gptr gvsa
  (H0 : no_alias gptr gvsa)
  (H1 : free TD Mem gptr = ret Mem')
  (H2 : mload TD Mem gvsa t al = ret gv),
  mload TD Mem' gvsa t al = ret gv.
Proof.
  intros.
  apply free_inv in H1.
  destruct H1 as [blk [ofs [hi [lo [J4 [J5 [J6 J7]]]]]]].
  apply mload_inv in H2.
  destruct H2 as [b [ofs' [m [mc [J1 [J2 J3]]]]]]; subst.
  unfold mload. simpl. rewrite J2.
  symmetry in J4.
  apply GV2ptr_inv in J4.
  destruct J4 as [b1 [ofs1 [m1 [J8 J9]]]]; subst.
  inv J9.
  simpl in H0. destruct H0. destruct H. clear H1 H0.
  eapply free_preserves_mload_aux in J3; eauto.
Qed.

Lemma free_preserves_wf_Mem : forall maxb TD M M' mptr0
  (Hfree: free TD M mptr0 = ret M')
  (Hwf: wf_Mem maxb TD M),
  wf_Mem maxb TD M'.
Proof.
  intros. destruct Hwf as [J1 J2].
  unfold wf_Mem.
  erewrite <- nextblock_free; eauto.
  split; auto.
    intros.
    eapply free_preserves_mload_inv in H; eauto.
Qed.

(*****************************************************************)
(* Properties of store. *)

Axiom mstore_mload_same: forall
      td Mem mp2 typ1 gv1 align1 Mem'
      (MSTORE: mstore td Mem mp2 typ1 gv1 align1 = ret Mem'),
    <<MLOAD: mload td Mem' mp2 typ1 align1 = ret gv1>>
.

Axiom mstore_aux_never_produce_new_ptr: forall
      TD mem0 mem1
      nptr ch val b o
      (MEM_NOALIAS: forall ptr ty a gv,
          mload TD mem0 ptr ty a = Some gv ->
          MemProps.no_alias nptr gv)
      (STORE_AUX: mstore_aux mem0 ch val b o = Some mem1)
      (NOALIAS: MemProps.no_alias nptr val)
  ,
    forall ptr ty a gv,
    mload TD mem1 ptr ty a = Some gv ->
    MemProps.no_alias nptr gv
.

Lemma store_preserves_mload_aux_inv: forall b1 b2 v2 m2 Mem' Mem ofs2
  (Hst: Mem.store m2 Mem b2 ofs2 v2 = ret Mem') mc ofs1 gvs0,
  mload_aux Mem' mc b1 ofs1 = ret gvs0 ->
  exists gvs2 : GenericValue,
     mload_aux Mem mc b1 ofs1 = ret gvs2 /\
     (forall v m,
      In (v, m) gvs0 -> In (v, m) gvs2 \/
      (forall b0 ofs0, v = Vptr b0 ofs0 -> v = v2 /\ m = m2)).
Proof.
  induction mc; simpl; intros.
    inv H.
    exists nil.
    split; auto.
      intros. inv H.

    inv_mbind'. symmetry in HeqR0.
    apply IHmc in HeqR0.
    destruct HeqR0 as [gvs2 [J1 J2]].
    rewrite J1.
    eapply Mem.store_preserves_load_inv in Hst; eauto.
    destruct Hst as [v1' [J3 J4]].
    rewrite J3.
    exists ((v1',a)::gvs2).
    split; auto.
      intros. simpl.
      simpl in H. destruct H as [H | H]; subst.
        inv H.
        destruct J4 as [J4 | J4]; subst; auto.

        apply J2 in H.
        destruct H as [H | H]; auto.
Qed.

Lemma mstore_aux_preserves_mload_aux_inv: forall mc b1 ofs1 gvs0 b2 mc' gvs1 Mem' Mem ofs2,
  mload_aux Mem' mc b1 ofs1 = ret gvs0 ->
  mstore_aux Mem mc' gvs1 b2 ofs2 = ret Mem' ->
  exists gvs2 : GenericValue,
     mload_aux Mem mc b1 ofs1 = ret gvs2 /\
     (forall v m,
      In (v, m) gvs0 -> In (v, m) gvs2 \/
      (forall b0 ofs0, v = Vptr b0 ofs0 -> In (v, m) gvs1)).
Proof.
  induction mc'; destruct gvs1; intros Mem' Mem ofs2 Hload Hstore; inv Hstore.
    exists gvs0. split; auto.

    inv_mbind'.
    destruct (AST.memory_chunk_eq a m); inv H0.
    destruct (has_chunk_eq v m); inv H1.
    inv_mbind'.
    apply IHmc' in H1; auto.
    destruct H1 as [gvs2 [J1 J2]].
    symmetry in HeqR.
    eapply store_preserves_mload_aux_inv in HeqR; eauto.
    destruct HeqR as [gvs3 [J3 J4]].
    exists gvs3.
    split; auto.
    intros.
    apply J2 in H.
    destruct H as [H | H]; subst;
      try solve [right; intros; subst; right; eauto].
    apply J4 in H.
    destruct H as [H | H]; subst; auto.
      right. intros. apply H in H0. destruct H0; subst; left; auto.
Qed.

Ltac destruct_ldst :=
match goal with
| H1 : mload _ _ _ _ _ = ret _,
  H2 : mstore _ _ _ _ _ _ = ret _ |- _ =>
  apply store_inv in H2;
  destruct H2 as [b [ofs [mc' [J6 [J5 J4]]]]];
  apply mload_inv in H1;
  destruct H1 as [b1 [ofs1 [m1 [mc [J1 [J2 J3]]]]]]; subst;
  unfold mload; simpl; rewrite J2;
  symmetry in J6; apply GV2ptr_inv in J6;
  destruct J6 as [b2 [ofs2 [m2 [J7 J8]]]]; subst; inv J8
end.

Lemma mstore_preserves_mload_inv: forall TD Mem' gptr ty al gvs0 Mem gvs1 t
  mp2 (H1 : mload TD Mem' gptr ty al = ret gvs0) align
  (H2 : mstore TD Mem mp2 t gvs1 align = Some Mem'),
  exists gvs2, mload TD Mem gptr ty al = ret gvs2 /\
     (forall v m,
      In (v, m) gvs0 -> In (v, m) gvs2 \/
      (forall b0 ofs0, v = Vptr b0 ofs0 -> In (v, m) gvs1)).
Proof.
  intros. destruct_ldst.
  eapply mstore_aux_preserves_mload_aux_inv; eauto.
Qed.

Lemma store_preserves_mload: forall b1 b2 v2 m2 Mem' Mem ofs2
  (Hneq: b1 <> b2) (Hst: Mem.store m2 Mem b2 ofs2 v2 = ret Mem') mc ofs1 gvs0,
  mload_aux Mem mc b1 ofs1 = ret gvs0 ->
  mload_aux Mem' mc b1 ofs1 = ret gvs0.
Proof.
  induction mc; simpl; intros; auto.
    inv_mbind'. symmetry in HeqR0.
    apply IHmc in HeqR0.
    rewrite HeqR0.
    erewrite Mem.load_store_other; eauto.
    rewrite <- HeqR. auto.
Qed.

Lemma mstore_aux_preserves_mload_aux: forall mc b1 ofs1 gvs0 b2
  (Hneq: b1 <> b2) mc' gvs1 Mem' Mem ofs2,
  mload_aux Mem mc b1 ofs1 = ret gvs0 ->
  mstore_aux Mem mc' gvs1 b2 ofs2 = ret Mem' ->
  mload_aux Mem' mc b1 ofs1 = ret gvs0.
Proof.
  induction mc'; destruct gvs1; intros Mem' Mem ofs2 Hload Hstore; inv Hstore; auto.
  inv_mbind'.
  destruct (AST.memory_chunk_eq a m); inv H0.
    destruct (has_chunk_eq v m); inv H1.
  inv_mbind'.
  apply IHmc' in H1; auto.
  eapply store_preserves_mload; eauto.
Qed.

Lemma mstore_preserves_mload: forall TD Mem' gptr ty al gvs0 Mem gv1 t
  mp2 (H1 : mload TD Mem gptr ty al = ret gvs0) align
  (H2 : mstore TD Mem mp2 t gv1 align = Some Mem')
  (Hna: no_alias mp2 gptr),
  mload TD Mem' gptr ty al = ret gvs0.
Proof.
  intros. destruct_ldst.
  simpl in Hna. destruct Hna as [[Hna _] _ ].
  eapply mstore_aux_preserves_mload_aux; eauto.
Qed.

Lemma nextblock_mstore_aux: forall b mc gvs M ofs M',
  mstore_aux M mc gvs b ofs = ret M' ->
  Mem.nextblock M = Mem.nextblock M'.
Proof.
  induction mc; destruct gvs; intros M ofs M' Hstore; inv Hstore; auto.
    inv_mbind'.
    destruct (AST.memory_chunk_eq a m); inv H0.
    destruct (has_chunk_eq v m); inv H1.
    inv_mbind'.
    apply IHmc in H1.
    symmetry in HeqR.
    apply Mem.nextblock_store in HeqR.
    rewrite <- HeqR. auto.
Qed.

Lemma nextblock_mstore: forall TD M gv1 M' mp2 t align0,
  mstore TD M mp2 t gv1 align0 = ret M' ->
  Mem.nextblock M = Mem.nextblock M'.
Proof.
  intros.
  apply store_inv in H.
  destruct H as [blk' [ofs' [mc [J1 [J2 J3]]]]].
  apply nextblock_mstore_aux in J3; auto.
Qed.

Lemma mstore_preserves_wf_lc: forall TD M' M mp2 t gv1 align
  (Hst: mstore TD M mp2 t gv1 align = Some M') lc
  (Hwf: wf_lc M lc),
  wf_lc M' lc.
Proof.
  unfold wf_lc.
  intros.
  apply Hwf in H.
  erewrite <- nextblock_mstore; eauto.
Qed.

Lemma store_preserves_mload_inv': forall b1 b2 v2 m2 Mem' Mem ofs2
  (Hneq: b1 <> b2) (Hst: Mem.store m2 Mem b2 ofs2 v2 = ret Mem') mc ofs1 gvs0,
  mload_aux Mem' mc b1 ofs1 = ret gvs0 ->
  mload_aux Mem mc b1 ofs1 = ret gvs0.
Proof.
  induction mc; simpl; intros; auto.
    inv_mbind'. symmetry in HeqR0.
    apply IHmc in HeqR0.
    rewrite HeqR0.
    erewrite <- Mem.load_store_other; eauto.
    rewrite <- HeqR. auto.
Qed.

Lemma mstore_aux_preserves_mload_inv_aux': forall mc b1 ofs1 gvs0 b2
  (Hneq: b1 <> b2) mc' gvs1 Mem' Mem ofs2,
  mload_aux Mem' mc b1 ofs1 = ret gvs0 ->
  mstore_aux Mem mc' gvs1 b2 ofs2 = ret Mem' ->
  mload_aux Mem mc b1 ofs1 = ret gvs0.
Proof.
  induction mc'; destruct gvs1; intros Mem' Mem ofs2 Hload Hstore; inv Hstore; auto.

    inv_mbind'.
    destruct (AST.memory_chunk_eq a m); inv H0.
    destruct (has_chunk_eq v m); inv H1.
    inv_mbind'.
    apply IHmc' in H1; auto.
    eapply store_preserves_mload_inv'; eauto.
Qed.

Lemma mstore_preserves_mload_inv': forall TD Mem' gptr ty al gvs0 Mem gv1 t
  mp2 (H1 : mload TD Mem' gptr ty al = ret gvs0) align
  (H2 : mstore TD Mem mp2 t gv1 align = Some Mem')
  (Hna: no_alias mp2 gptr),
  mload TD Mem gptr ty al = ret gvs0.
Proof.
  intros. destruct_ldst.
  simpl in Hna. destruct Hna as [[Hna _] _ ].
  eapply mstore_aux_preserves_mload_inv_aux'; eauto.
Qed.

Lemma bounds_mstore_aux: forall b mc gvs M ofs M',
  mstore_aux M mc gvs b ofs = ret M' ->
  forall b', Mem.bounds M b' = Mem.bounds M' b'.
Proof.
  induction mc; destruct gvs; intros M ofs M' Hstore b'; inv Hstore; auto.

    inv_mbind'.
    destruct (AST.memory_chunk_eq a m); inv H0.
    destruct (has_chunk_eq v m); inv H1.
    inv_mbind'.
    eapply IHmc in H1; eauto.
    symmetry in HeqR.
    eapply Mem.bounds_store in HeqR; eauto.
    rewrite <- HeqR. eauto.
Qed.

Lemma bounds_mstore: forall TD M gv1 M' mp2 t align0,
  mstore TD M mp2 t gv1 align0 = ret M' ->
  forall b', Mem.bounds M b' = Mem.bounds M' b'.
Proof.
  intros.
  apply store_inv in H.
  destruct H as [blk' [ofs' [mc' [J1 [J2 J3]]]]].
  eapply bounds_mstore_aux in J3; eauto.
Qed.

(*****************************************************************)
(* Properties of alloca. *)
Fixpoint mcs2uninits (mc:list AST.memory_chunk) : GenericValue :=
match mc with
| nil => nil
| c::mc => (Vundef, c)::mcs2uninits mc
end.

Lemma alloc_preserves_mload_aux_inv': forall M M' mb lo hi b
  (Hal : Mem.alloc M lo hi = (M', mb)) mc ofs gvs1
  (H : mload_aux M' mc b ofs = ret gvs1),
  mload_aux M mc b ofs = ret gvs1 /\ b <> mb \/
  gvs1 = mcs2uninits mc /\ b = mb.
Proof.
  induction mc; simpl; intros.
    inv H.
    destruct (peq b mb); subst; auto.

    inv_mbind'.
    symmetry in HeqR.
    assert (J:=HeqR).
    apply Mem.load_valid_access in J.
    eapply Mem.valid_access_alloc_inv in J; eauto.
    symmetry in HeqR0. apply IHmc in HeqR0.
    destruct (eq_block b mb); subst.
      destruct J as [J1 [J2 J3]].
      erewrite Mem.load_alloc_same' in HeqR; eauto.
      inv HeqR.
      destruct HeqR0 as [[J4 J5] | [J4 J5]]; subst;
        try solve [congruence | tauto].

      destruct HeqR0 as [[J4 J5] | [J4 J5]]; subst; try solve [congruence].
      left.
      rewrite J4.
      split; auto.
        apply Mem.valid_access_implies with (p2:=Nonempty) in J; try constructor.
        apply Mem.valid_access_valid_block in J.
        erewrite Mem.load_alloc_unchanged in HeqR; eauto.
        rewrite HeqR. auto.
Qed.

Lemma alloc_drop_preserves_mload_aux_inv': forall M M' mb lo hi b
  (Hal : Mem.alloc M lo hi = (M', mb)) mc ofs gvs1
  M''
  (DROP: Mem.drop_perm M' mb lo hi Writable = ret M'')
  (H : mload_aux M'' mc b ofs = ret gvs1),
  mload_aux M mc b ofs = ret gvs1 /\ b <> mb \/
  gvs1 = mcs2uninits mc /\ b = mb.
Proof.
  i.
  ginduction mc; ii; ss.
  - inv H.
    destruct (eq_block b mb).
    + right. split; ss.
    + left. split; ss.
  - destruct (Mem.load a M'' b ofs) eqn:T; ss.
    destruct (mload_aux M'' mc b (ofs + size_chunk a)) eqn:T2; ss.
    clarify.
    hexploit Mem.load_drop; try eassumption.
    { right. right. right. econs. }
    intro EQ.
    rewrite EQ in *.
    exploit Mem.load_valid_access; eauto; intro VALID; des.
    eapply Mem.valid_access_alloc_inv in VALID; eauto.
    eapply IHmc in T2; eauto.

    destruct (eq_block b mb).
    + clarify. right. split; ss.
      des_ifs. des; ss.
      erewrite Mem.load_alloc_same' in T; eauto. clarify.
    + left. split; ss.
      eapply Mem.valid_access_implies with (p2:=Nonempty) in VALID; eauto; [|econs].
      apply Mem.valid_access_valid_block in VALID.
      eapply Mem.load_alloc_unchanged in Hal; eauto.
      rewrite <- Hal. rewrite T.
      des; ss. rewrite T2. ss.
Qed.

Lemma mcs2uninits_spec: forall v m mc, In (v, m) (mcs2uninits mc) -> v = Vundef.
Proof.
  induction mc; simpl; intros.
    inv H.

    destruct H as [H | H]; auto.
      inv H; auto.
Qed.

Lemma alloc_preserves_mload_aux_inv: forall M M' mb lo hi b
  (Hal : Mem.alloc M lo hi = (M', mb)) mc ofs gvs1
  (H : mload_aux M' mc b ofs = ret gvs1),
  mload_aux M mc b ofs = ret gvs1 /\ b <> mb \/
  (forall v m, In (v, m) gvs1 -> v = Vundef) /\ b = mb.
Proof.
  intros.
  eapply alloc_preserves_mload_aux_inv' in H; eauto.
  destruct H as [H | H]; auto.
  right.
  destruct H; subst.
  split; auto.
    intros.
    eapply mcs2uninits_spec; eauto.
Qed.

Lemma alloc_drop_preserves_mload_aux_inv: forall M M' mb lo hi b
  (Hal : Mem.alloc M lo hi = (M', mb)) mc ofs gvs1
  M''
  (DROP: Mem.drop_perm M' mb lo hi Writable = ret M'')
  (H : mload_aux M'' mc b ofs = ret gvs1),
  mload_aux M mc b ofs = ret gvs1 /\ b <> mb \/
  (forall v m, In (v, m) gvs1 -> v = Vundef) /\ b = mb.
Proof.
  intros.
  eapply alloc_drop_preserves_mload_aux_inv' in H; eauto.
  destruct H as [H | H]; auto.
  right.
  destruct H; subst.
  split; auto.
    intros.
    eapply mcs2uninits_spec; eauto.
Qed.

Ltac destruct_allocld :=
match goal with
| Hal : malloc _ _ _ _ _ = ret _,
  H : mload _ _ _ _ _ = ret _ |- _ =>
  apply mload_inv in H;
  destruct H as [b [ofs [m [mc [J1 [J2 J3]]]]]]; subst;
  apply malloc_inv in Hal;
  unfold mload; simpl; rewrite J2
end.
(*   apply malloc_inv in Hal; *)
(*   destruct Hal as [n [J4 [J5 J6]]]; *)
(*   unfold mload; simpl; rewrite J2 *)

Lemma alloca_preserves_mload_inv: forall TD M M' mb align0 gn tsz
  (Hal : alloca TD M tsz gn align0 = ret (M', mb))
  gptr gvs1 ty al
  (H : mload TD M' gptr ty al = ret gvs1),
  mload TD M gptr ty al = ret gvs1 /\ no_alias_with_blk gptr mb \/
  (forall v m, In (v, m) gvs1 -> v = Vundef) /\ ~ no_alias_with_blk gptr mb.
Proof.
  ii. unfold alloca in *.
  remember (match GV2int TD Size.ThirtyTwo gn with
            | ret n => Size.to_Z tsz * n
            | merror => 0
            end) as hi. clear Heqhi.
  des_ifs. unfold option_map, flip in *.
  des_ifs.
  unfold mload in *. des_ifs.
  exploit alloc_drop_preserves_mload_aux_inv; try exact H; eauto; []; i.
  unfold GV2ptr in *. des_ifs.
  des.
  - left. split; ss.
  - right. split; ss.
    ii. des. ss.
Qed.

Lemma nextblock_malloc: forall TD M tsz gn M' align0 mb,
  malloc TD M tsz gn align0 = ret (M', mb) ->
  (Mem.nextblock M + 1)%positive = Mem.nextblock M'.
Proof.
  intros.
  apply malloc_inv in H.
  apply Mem.nextblock_alloc in H.
  rewrite H. rewrite Pplus_one_succ_r; auto.
Qed.

Lemma nextblock_alloca: forall TD M tsz gn M' align0 mb,
  alloca TD M tsz gn align0 = ret (M', mb) ->
  (Mem.nextblock M + 1)%positive = Mem.nextblock M'.
Proof.
  intros.
  apply alloca_inv in H.
  unfold option_map, flip in *. des.
  des_ifs; apply Mem.nextblock_alloc in Heq; apply Mem.nextblock_drop in Heq0;
    rewrite Heq0; rewrite Heq; rewrite Pplus_one_succ_r; auto.
Qed.

Lemma malloc_result: forall TD M tsz gn M' align0 mb,
  malloc TD M tsz gn align0 = ret (M', mb) ->
  mb = Mem.nextblock M.
Proof.
  intros.
  apply malloc_inv in H.
  apply Mem.alloc_result in H; auto.
  (* destruct H as [n [J1 [J2 J3]]]. *)
  (* apply Mem.alloc_result in J3; auto. *)
Qed.

Lemma alloca_result: forall TD M tsz gn M' align0 mb,
  alloca TD M tsz gn align0 = ret (M', mb) ->
  mb = Mem.nextblock M.
Proof.
  intros.
  apply alloca_inv in H.
  unfold option_map, flip in *. des.
  des_ifs; apply Mem.alloc_result in Heq; ss.
  (* destruct H as [n [J1 [J2 J3]]]. *)
  (* apply Mem.alloc_result in J3; auto. *)
Qed.

Lemma alloc_drop_preserves_mload_aux: forall M M' mb lo hi b
  (Hal : Mem.alloc M lo hi = (M', mb)) mc ofs gvs1
  M''
  (DROP: Mem.drop_perm M' mb lo hi Writable = ret M'')
  (H : mload_aux M mc b ofs = ret gvs1),
  mload_aux M'' mc b ofs = ret gvs1.
Proof.
  i. ginduction mc; ii; ss.
  destruct (Mem.load a M b ofs) eqn:LOAD; ss.
  destruct (mload_aux M mc b (ofs + size_chunk a)) eqn:LOAD_AUX; ss.
  clarify.
  exploit Mem.load_drop; try eassumption.
  { right. right. right. econs. }
  intro EQ. rewrite EQ in *.
  exploit Mem.load_alloc_other; eauto; []; intro LOAD1; des.
  rewrite LOAD1.
  exploit IHmc; eauto; []; intro MLOAD_AUX1; des.
  rewrite MLOAD_AUX1. ss.
Qed.

Ltac u_alloca := unfold alloca, option_map, flip in *.

Lemma alloca_preserves_wf_Mem : forall maxb TD M tsz gn align0 M' mb
  (Hmlc: alloca TD M tsz gn align0 = ret (M', mb))
  (Hwf: wf_Mem maxb TD M),
  wf_Mem maxb TD M'.
Proof.
  eauto.
  intros. destruct Hwf as [J1 J2].
  assert ((Mem.nextblock M + 1)%positive = Mem.nextblock M') as EQ.
    eapply nextblock_alloca; eauto.
  split.
    rewrite <- EQ.
    intros.
    eapply alloca_preserves_mload_inv in H; eauto.
    destruct H as [[G _]| [G _]]; subst; eauto.
      apply J1 in G. eapply valid_ptrs__trans; eauto. rewrite <- Pplus_one_succ_r; apply Ple_succ.
      eapply undefs_valid_ptrs; eauto.

    eapply Plt_trans; eauto. rewrite <- EQ. rewrite <- Pplus_one_succ_r; apply Plt_succ.
Qed.

Lemma alloca_preserves_wf_lc_in_tail: forall TD M M' tsz gn align0 mb lc
  (Halloca: alloca TD M tsz gn align0 = ret (M', mb))
  (Hwf: wf_lc M lc), wf_lc M' lc.
Proof.
  unfold wf_lc.
  intros. apply Hwf in H.
  eapply valid_ptrs__trans; eauto.
  erewrite <- nextblock_alloca with (M':=M'); eauto.
  rewrite <- Pplus_one_succ_r; apply Ple_succ.
Qed.

(* The current design of malloc does not check alignment! It must ensure that
   mload is successful at the allocated address. To do so, malloc must ensure
   all subcomponents in an aggregated object are well-aligned! *)
Axiom malloc_mload_aux_undef: forall TD t tsz mcs M gn align0 M' mb gvs gl
  (Hsz: getTypeAllocSize TD t = Some tsz)
  (Hflatten: flatten_typ TD t = Some mcs)
  (Hal : malloc TD M tsz gn align0 = ret (M', mb))
  (Hc2v : Opsem.const2GV TD gl (const_undef t) = ret gvs),
  mload_aux M' mcs mb (Int.signed 31 (Int.repr 31 0)) = ret gvs.

Axiom alloca_mload_aux_undef: forall TD t tsz mcs M gn align0 M' mb gvs gl
  (Hsz: getTypeAllocSize TD t = Some tsz)
  (Hflatten: flatten_typ TD t = Some mcs)
  (Hal : alloca TD M tsz gn align0 = ret (M', mb))
  (Hc2v : Opsem.const2GV TD gl (const_undef t) = ret gvs),
  mload_aux M' mcs mb (Int.signed 31 (Int.repr 31 0)) = ret gvs.

Lemma redundant__wf_globals: forall maxb gl,
  wf_globals maxb gl ->
  genericvalues_inject.wf_globals maxb gl.
Proof.
  intros. destruct H.
  induction gl; auto.
Qed.

(**************************************************)
(* Properties of externals *)
Axiom callExternalOrIntrinsics_preserves_mload: forall Mem fid gvsa gvs gvsv
  Mem' TD oresult ty al dck gl tret targs tr,
  callExternalOrIntrinsics TD gl Mem fid tret targs dck gvs
    = ret (oresult, tr, Mem') ->
  mload TD Mem gvsa ty al = ret gvsv ->
  mload TD Mem' gvsa ty al = ret gvsv.

(**************************************************)
(* Properties of inject_init *)
Definition inject_init (maxb:positive) : MoreMem.meminj :=
fun (b:Values.block) =>
if Pos.leb b maxb then Some (b, 0)
else None.

End MemProps.


Require Import VST.msl.msl_direct.
Require Import VST.msl.seplog.
Require Import VST.msl.log_normalize.

Require Import neg_logic.
Require Import modal_logic.
Require Import ssl_shares.

Definition Emp {A} {ND : NatDed A} {SL : @SepLog A ND} := @VST.msl.seplog.emp A ND SL.

Open Local Scope logic.

Definition sprop {A} `{SL : SepLog A} (P : Prop) : A :=
  Emp && !!P.
Notation "'!!!' e" := (sprop e) (at level 25) : logic.

Lemma sprop_FF {A} `{SL : SepLog A}:
  !!! False = FF.
Proof.
  apply pred_ext.
  apply andp_left2.
  apply prop_left.
  contradiction.
  apply FF_left.
Qed.

(* LOGIC AXIOMS *)

Class PreciseSepLog (A : Type) {ND : NatDed A} {SL : @SepLog A ND} : Type := mkPreciseSepLog {
  precise : A -> Prop;
  precisely : A -> A;

  precisely_derives: forall P Q R,
    precisely P |-- (P * Q) && (P * R) --> P * (Q && R);
  derives_precisely: forall G P,
    (forall Q R, G |-- (P * Q) && (P * R) --> P * (Q && R)) ->
    G |-- precisely P;
  precise_precisely: forall P,
    precise P <-> TT |-- precisely P;

(*
  FF_precisely : forall G,
    G |-- precisely FF;
*)
(* On pen-and-paper these are probably axioms, but in the Coq development
   we can prove them from the rules for allp and exp.
  andp_precisely1 : forall G P Q,
    G |-- precisely P ->
    G |-- precisely (P && Q);
  orp_precisely1: forall G P Q,
    G |-- precisely P ->
    G |-- precisely Q ->
    (P * TT) && (Q * TT) |-- FF ->
    G |-- precisely (P || Q); *)
  allp_precisely : forall G T P,
    (exists x : T, G |-- precisely (P x)) ->
    G |-- precisely (ALL x : T, P x);
  exp_precisely : forall G T P,
    (forall x : T, G |-- precisely (P x)) ->
    (forall x y : T, G && (P x * TT) && (P y * TT) |-- !!(x = y)) ->
    G |--  precisely (EX x : T, (P x));
(*
  emp_precisely : forall G,
    G |-- precisely Emp;
*)
  star_precisely : forall G P Q,
    G |-- precisely P ->
    G |-- precisely Q ->
    G |-- precisely (P * Q);
}.

Class ScaledSepLog (A RT : Type)
  {ND : NatDed A} {SL : @SepLog A ND} {PSL : @PreciseSepLog A ND SL}
  {ML : @ModLog RT A ND} {MLS : @ModLogSeq RT A ND ML} : Type := mkSSL {
  uniform : pshare -> A;
  factorR : pshare -> RT;
  dot : pshare -> A -> A := fun sh => diamond (factorR sh);

(* not true since Emp |-- uniform pi...
  uniform_inj: forall pi1 pi2, (uniform pi1 |-- uniform pi2) -> pi1 = pi2; *)
  uniform_emp: forall pi, Emp |-- (uniform pi);
  (* Right to left is easy, given uniform_emp.  Left to right
     requires disjointness. IFF? *)
  star_uniform: forall pi,
    (uniform pi) * (uniform pi) = uniform pi;
  uniform_dot: forall pi pi' P,
        (P      |-- uniform pi)    <->
    (dot pi' P  |-- uniform (pbow pi pi'));

  factorR_CD : forall sh, Modal_CD (factorR sh);

  factorR1_T : Modal_T (factorR pfullshare);

  factorR_seqR : forall sh1 sh2, seqR (factorR sh1) (factorR sh2) = factorR (pbow sh2 sh1);

  dot_precise: forall P sh,
    precise P <-> precise (dot sh P);

  dot_prop: forall sh (P : Prop),
    dot sh (!!! P) = !!!P; (* We use the stronger version of !!! here *)

  dot_plus1 : forall P sh1 sh2 sh3, join sh1 sh2 sh3 ->
                dot sh3 P |-- (dot sh1 P) * (dot sh2 P);
  dot_plus2 : forall P, precise P -> forall sh1 sh2 sh3, join sh1 sh2 sh3 ->
                (dot sh1 P) * (dot sh2 P) |-- dot sh3 P;

  dot_star : forall P Q pi pi',
    P |-- uniform pi ->
    Q |-- uniform pi ->
      dot pi' (P * Q) = (dot pi' P) * (dot pi' Q);
(* wand? ewand? *)
}.

Existing Instance factorR_CD.
Existing Instance factorR1_T.

Class ScaledMapsLog (A B RT : Type)
  {ND : NatDed A} {SL : @SepLog A ND} {PSL : @PreciseSepLog A ND SL}
  {ML : @ModLog RT A ND} {MLS : @ModLogSeq RT A ND ML}
  {SSL : @ScaledSepLog A RT ND SL PSL ML MLS} : Type := mkScaledMapsLog {

  maps_to' : pshare -> B -> A;
  maps_to'_nonempty : forall pi b,
    maps_to' pi b |-- !Emp;
  maps_to'_uniform : forall pi b,
    maps_to' pi b |-- uniform pi;
  maps_to'_precise : forall pi b,
    precise (maps_to' pi b);
  dot_maps_to' : forall pi1 pi2 b, dot pi1 (maps_to' pi2 b) = maps_to' (pbow pi2 pi1) b;
}.

Class FracIndLog (A RT : Type) {ND : NatDed A} {SL : @SepLog A ND}
  {PSL: @PreciseSepLog A ND SL} {ML : @ModLog RT A ND} {MLS : @ModLogSeq RT A ND ML}
  {SSL : @ScaledSepLog A RT ND SL PSL ML MLS} : Type := mkFracIndLog {

  withinR : RT;
  shrinkingR : pshare -> RT;

  within := [withinR];
  within_T : Modal_T withinR;
  within_4 : Modal_4 withinR;

  shrinking (pi : pshare) := [shrinkingR pi];
  shrinking_4 : forall pi, Modal_4 (shrinkingR pi); (* Supposedly this may follow from W *)
  shrinking_W : forall pi, Modal_W (shrinkingR pi);

  shrinkingR_withinR : forall pi, seqR (shrinkingR pi) withinR = shrinkingR pi;
  withinR_shrinkingR : forall pi, seqR withinR (shrinkingR pi) = shrinkingR pi;

  conj_within_star: forall P Q R,
    (P * Q) && (within R) |-- (P && within R) * (Q && within R);

  conj_shrinking_star1: forall P Q R sh,
    P |-- (uniform sh && !Emp)%logic ->
    (P * Q) && (shrinking sh R) |-- (P && shrinking sh R) * (Q && R)
}.

Existing Instance within_T.
Existing Instance within_4.
Existing Instance shrinking_W.
Existing Instance shrinking_4.

Definition covariant {A} {ND : NatDed A} {B} (F : (B -> A) -> (B -> A)) : Prop :=
  forall P Q, P |-- Q -> F P |-- F Q.

Class CorecLog (RT A : Type) {ND : NatDed A} {SL : @SepLog A ND}
  {ML : @ModLog RT A ND} {MLS : @ModLogSeq RT A ND ML} : Type := mkCorecLog {

  corec {B} : ((B -> A) -> (B -> A)) -> (B -> A);
  corec_fold_unfold {B}: forall F : ((B -> A) -> (B -> A)),
    covariant F ->
    corec F = F (corec F);
}.

(* PROOF THEORY *)

Section PSL_ProofTheory.

Context {A RT : Type}.
Context {ND : NatDed A}.
Context {CND : @ClassicNatDed A ND}.
Context {SL : @SepLog A ND}.
Context {CS : @ClassicalSep A ND SL}.
Context {PSL : @PreciseSepLog A ND SL}.

Lemma sepcon_andp_distrib: forall P Q R,
  (P * (Q && R)) |-- (P * Q) && (P * R).
Proof.
  intros. apply andp_right; apply sepcon_derives; auto.
  apply andp_left1. trivial.
  apply andp_left2. trivial.
Qed.

Lemma precise_distrib: forall P, precise P <-> (forall Q R,
  (P * Q) && (P * R) |-- (P * (Q && R))).
Proof.
  split; intros.
  + rewrite precise_precisely in H.
    rewrite <- (TT_andp (P * Q && _)).
    eapply derives_trans. apply andp_derives. eapply derives_trans. apply H. apply precisely_derives.
    apply derives_refl.
    rewrite andp_comm.
    apply modus_ponens.
  + rewrite precise_precisely.
    apply derives_precisely. intros R S.
    rewrite <- imp_andp_adjoint.
    rewrite TT_andp.
    apply H.
Qed.

Lemma precisely_strengthen: forall P,
    P * TT --> precisely P |-- precisely P.
Proof.
  intros.
  apply derives_precisely. intros R S.
  rewrite <- imp_andp_adjoint.
  rewrite <- (andp_dup ((P * R) && (P * S))).
  rewrite <- (andp_assoc _ ((P * R) && (P * S)) ((P * R) && (P * S))).
  rewrite imp_andp_adjoint.
  rewrite andp_comm.
  eapply derives_trans.
  apply andp_derives. apply andp_left1. apply sepcon_derives. apply derives_refl. apply TT_right.
  apply derives_refl.
  eapply derives_trans. apply modus_ponens.
  apply precisely_derives.
Qed.

Lemma FF_precisely : forall G,
  G |-- precisely FF.
Proof.
  intros. apply derives_precisely. intros.
  rewrite <- imp_andp_adjoint.
  apply andp_left2. apply andp_left2.
  rewrite wand_sepcon_adjoint.
  apply FF_left.
Qed.

Lemma emp_precisely : forall G,
  G |-- precisely Emp.
Proof.
  intro. apply derives_precisely. intros R S.
  repeat (rewrite sepcon_comm, sepcon_emp).
  rewrite <- imp_andp_adjoint.
  apply andp_left2. apply derives_refl.
Qed.

(*
Lemma andp_precisely1: forall G P Q,
  G |-- precisely P ->
  G |-- precisely (P && Q).
Proof.
  intros.
  apply derives_precisely. intros R S.
  eapply derives_trans. eapply derives_trans. apply H.
  apply (precisely_derives P R S).
  rewrite <- imp_andp_adjoint.
  rewrite <- (andp_dup (P && Q * R && (P && Q * S))).
  rewrite <- (andp_assoc (P * R && (P * S) --> P * (R && S)) _ _).
  rewrite imp_andp_adjoint.
  eapply derives_trans.
  apply andp_derives. apply derives_refl.
  apply andp_derives; apply sepcon_derives.
  apply andp_left1. apply derives_refl. apply derives_refl.
  apply andp_left1. apply derives_refl. apply derives_refl.
  rewrite andp_comm.
  eapply derives_trans. apply modus_ponens.
  rewrite <- imp_andp_adjoint.

Check modus_ponens.
a
  rewrite andp_comm.

Lemma allp_precisely' : forall G T P,
  (exists x : T, G |-- precisely (P x)) ->
  G |-- precisely (ALL x : T, P x).
Proof.
  intros.
  apply derives_precisely. intros R S.
  destruct H.
  eapply derives_trans. apply H.
  rewrite <- imp_andp_adjoint.
  rewrite andp_comm.

apply derives_trans with (ALL x : T, (P x * (R && S))).
2: apply allp_left.
SearchAbout allp.

Check exp_sepcon1.
Check allp_sepcon.

rewrite sepcon_allp.
  apply
  rewrite imp_andp_adjoint.
  eapply derives_trans. apply andp_derives; apply sepcon_derives.
  apply allp_left with x. apply derives_refl. apply derives_refl.
  apply allp_left with x. apply derives_refl. apply derives_refl.

  eapply derives_trans. apply precisely_derives.

  precisely_derives: forall P Q R,
    precisely P |-- (P * Q) && (P * R) --> P * (Q && R);
  derives_precisely: forall G P,
    (forall Q R, G |-- (P * Q) && (P * R) --> P * (Q && R)) ->
    G |-- precisely P;
  precise_precisely: forall P,
    precise P <-> TT |-- precisely P;
*)

Lemma precise_eq:
  precise = fun P => forall Q R, (P * (Q && R)) = (P * Q) && (P * R).
Proof.
  extensionality P. apply prop_ext. split; intros.
  apply pred_ext. apply sepcon_andp_distrib.
  apply precise_distrib. apply H.
  rewrite precise_distrib. intros.
  rewrite <- H. apply derives_refl.
Qed.

Lemma precisely_weaken: forall P,
  precisely P |-- P * TT --> precisely P.
Proof.
  intro. rewrite <- imp_andp_adjoint.
  apply andp_left1. apply derives_refl.
Qed.

Lemma precisely_equiv: forall P,
  precisely P = P * TT --> precisely P.
Proof. intro. apply pred_ext. apply precisely_weaken. apply precisely_strengthen. Qed.

Lemma precise_precisely': forall P,
  precise P <-> P * TT |-- precisely P.
Proof.
  split; intros.
  eapply derives_trans. apply TT_right.
  rewrite <- precise_precisely. trivial.
  rewrite precise_precisely. rewrite precisely_equiv.
  rewrite <- imp_andp_adjoint.
  apply andp_left2. trivial.
Qed.

Lemma andp_precisely1: forall G P Q,
  G |-- precisely P ->
  G |-- precisely (P && Q).
Proof.
  intros. rewrite andp_is_allp.
  apply allp_precisely.
  exists true. trivial.
Qed.

Lemma orp_precisely1: forall G P Q,
  G |-- precisely P ->
  G |-- precisely Q ->
  G && (P * TT) && (Q * TT) |-- FF ->
  G |-- precisely (P || Q).
Proof.
  intros. rewrite orp_is_exp.
  apply exp_precisely; intros.
  destruct x; trivial.
  destruct x, y; try (apply prop_right; trivial; fail); apply FF_right; auto.
  rewrite andp_assoc. rewrite (andp_comm (Q * TT)). rewrite <- andp_assoc. trivial.
Qed.

Lemma orp_precisely2: forall R S P Q,
  R |-- precisely P ->
  S |-- precisely Q ->
  (R * TT) && (Q * TT) |-- FF ->
  (S * TT) && (P * TT) |-- FF ->
  R || S |-- precisely (P || Q).
Proof.
  intros.
  apply orp_left; apply orp_precisely1; auto.
  + rewrite precisely_equiv. rewrite <- imp_andp_adjoint.
    apply FF_right.
    eapply derives_trans. 2: apply H1.
    apply andp_derives.
    apply sepcon_TT.
    apply derives_refl.
  + rewrite andp_comm. rewrite <- andp_assoc.
    apply andp_left1.
    eapply derives_trans. 2: apply H1.
    rewrite andp_comm.
    apply andp_derives.
    apply sepcon_TT.
    apply derives_refl.
  + rewrite precisely_equiv. rewrite <- imp_andp_adjoint.
    apply FF_right.
    eapply derives_trans. 2: apply H2.
    apply andp_derives.
    apply sepcon_TT.
    apply derives_refl.
  + apply andp_left1.
    eapply derives_trans. 2: apply H2.
    apply andp_derives.
    apply sepcon_TT.
    apply derives_refl.
Qed.

Lemma exp_precisely2 : forall T G P,
    (forall x : T, G x |-- precisely (P x)) ->
    (forall x y, G x && (P y * TT) |-- !!(x = y)) ->
    EX x : T, G x |--  precisely (EX x : T, (P x)).
Proof.
  intros.
  apply exp_left. intro x.
  apply exp_precisely.
  intro.
  spec H0 x x0.
  rewrite <- (andp_dup (G x)).
  rewrite precisely_equiv. rewrite <- imp_andp_adjoint.
  rewrite andp_assoc.
  eapply derives_trans.
  apply andp_derives. apply derives_refl. apply H0.
  rewrite andp_comm.
  rewrite imp_andp_adjoint.
  apply prop_left. intro. subst x0.
  rewrite <- imp_andp_adjoint. apply andp_left2.
  apply H.
  intros a b.
  rewrite imp_andp_adjoint.
  rewrite <- (andp_dup (G x)).
  rewrite andp_assoc.
  rewrite andp_comm.
  rewrite imp_andp_adjoint.
  eapply derives_trans. apply H0.
  apply prop_left. intro. subst x.
  rewrite <- imp_andp_adjoint. apply andp_left2.
  rewrite <- imp_andp_adjoint. apply H0.
Qed.

Lemma exp_induct: forall T (Q : A) (P : T -> A),
  (forall x : T, Q && (P x * TT) |-- precisely (P x)) ->
  (forall x y, (P x * TT) && (P y * TT) |-- !!(x = y)) ->
  Q && ((EX x : T, P x) * TT) |-- precisely (EX x : T, P x).
Proof.
  intros.
  rewrite exp_sepcon1.
  rewrite exp_andp2.
  apply exp_precisely2; trivial.
  intros.
  spec H0 x y.
  eapply derives_trans. 2: apply H0.
  apply andp_derives. 2: apply derives_refl.
  apply andp_left2.
  apply derives_refl.
Qed.

Lemma orp_induct: forall Q R S,
  Q && (R * TT) |-- precisely R ->
  Q && (S * TT) |-- precisely S ->
  (R * TT) && (S * TT) |-- FF ->
  Q && ((R || S) * TT) |-- precisely (R || S).
Proof.
  intros. rewrite orp_is_exp.
  apply exp_induct.
  intro x. destruct x; trivial.
  intros x y. destruct x,y.
  apply prop_right; trivial.
  apply FF_right. trivial.
  apply FF_right. rewrite andp_comm. trivial.
  apply prop_right; trivial.
Qed.

Lemma TT_derives_precisely: forall P,
  TT |-- precisely P ->
  precise P.
Proof.
  intros.
  rewrite precise_precisely.
  eapply derives_trans.
  apply TT_right. trivial.
Qed.

Lemma FF_precise:
  precise FF.
Proof.
  rewrite precise_precisely'.
  rewrite wand_sepcon_adjoint.
  apply FF_left.
Qed.

Lemma andp_precise1: forall P Q,
  precise P ->
  precise (P && Q).
Proof.
  do 2 intro.
  do 2 rewrite precise_precisely'.
  intro.
  rewrite wand_sepcon_adjoint.
  apply andp_left1.
  rewrite <- wand_sepcon_adjoint.
  apply andp_precisely1. trivial.
Qed.

Lemma andp_precisely2: forall G P Q,
  G |-- precisely Q ->
  G |-- precisely (P && Q).
Proof.
  do 3 intro. rewrite andp_comm.
  apply andp_precisely1.
Qed.

Lemma andp_precise2: forall P Q,
  precise Q ->
  precise (P && Q).
Proof.
  do 2 intro. rewrite andp_comm.
  apply andp_precise1.
Qed.

Lemma orp_precise: forall P Q,
  precise P ->
  precise Q ->
  (P * TT) && (Q * TT) |-- FF ->
  precise (P || Q).
Proof.
  do 2 intro. do 3 rewrite precise_precisely'.
  intros.
  rewrite <- (TT_andp (_ * TT)).
  apply orp_induct.
  apply andp_left2. trivial.
  apply andp_left2. trivial.
  trivial.
Qed.

Lemma emp_precise:
  precise Emp.
Proof.
  rewrite precise_precisely'. apply emp_precisely.
Qed.

Lemma prop_precise: forall P,
  precise (!!! P).
Proof.
  intro. apply andp_precise1. apply emp_precise.
Qed.

Lemma star_precise: forall P Q,
  precise P ->
  precise Q ->
  precise (P * Q).
Proof.
  do 2 intro. do 3 rewrite precise_precisely'.
  intros. apply star_precisely.
  apply derives_trans with (P * TT); trivial.
  rewrite sepcon_assoc. apply sepcon_derives. apply derives_refl. apply TT_right.
  apply derives_trans with (Q * TT); trivial.
  rewrite (sepcon_comm P), sepcon_assoc. apply sepcon_derives. apply derives_refl. apply TT_right.
Qed.

Lemma precise_derives_precisely: forall P Q,
  precise P -> Q |-- precisely P.
Proof.
  intros. eapply derives_trans.
  apply TT_right.
  rewrite precise_precisely in H. trivial.
Qed.

Lemma star_precisely2 : forall P Q,
  precise P ->
  P * (precisely Q) |-- precisely (P * Q).
Proof.
  intros.
  apply derives_precisely. intros R S.
  rewrite <- imp_andp_adjoint.
  rewrite precise_eq in H.
  pose proof (H (Q * R) (Q * S)).
  do 2 rewrite <- sepcon_assoc in H0. rewrite <- H0. clear H0.
  spec H (precisely Q) (Q * R && (Q * S)).
  rewrite <- H. clear H.
  rewrite sepcon_assoc.
  apply sepcon_derives. trivial.
  rewrite imp_andp_adjoint.
  apply precisely_derives.
Qed.

End PSL_ProofTheory.

Section SSL_ProofTheory.

Context {A RT : Type}.
Context {ND : NatDed A}.
Context {CND : @ClassicNatDed A ND}.
Context {SL : @SepLog A ND}.
Context {PSL : @PreciseSepLog A ND SL}.
Context {ML : @ModLog RT A ND}.
Context {MLS : @ModLogSeq RT A ND ML}.
Context {SSL : @ScaledSepLog A RT ND SL PSL ML MLS}.

Lemma dot_FF: forall sh,
  dot sh FF = FF.
Proof. intro. apply diamond_FF. Qed.

Lemma dot_positive: forall sh P Q,
  P |-- Q ->
  dot sh P |-- dot sh Q.
Proof. intros. apply diamond_positive. trivial. Qed.

Lemma dot_andp: forall sh (P Q : A),
  dot sh (P && Q) = dot sh P && dot sh Q.
Proof. intros. apply diamond_andp. Qed.

Lemma dot_orp: forall sh (P Q : A),
  dot sh (P || Q) = dot sh P || dot sh Q.
Proof. intros. apply diamond_orp. Qed.

Lemma dot_allp1 {C}: forall sh (P : C -> A),
  dot sh (ALL c : C, P c) |-- ALL c : C, dot sh (P c).
Proof. intros. apply diamond_allp1. Qed.

Lemma dot_allp {C}: forall sh (P : C -> A), inhabited C ->
  dot sh (ALL c : C, P c) = ALL c : C, dot sh (P c).
Proof. intros. apply diamond_allp. trivial. Qed.

Lemma dot_exp {C}: forall sh (P : C -> A),
  dot sh (EX c : C, P c) = EX c : C, dot sh (P c).
Proof. intros. apply diamond_exp. Qed.

Definition factor (sh : pshare) : A := dot sh TT.
Lemma dot_WN: forall sh P,
  TT |-- P -> factor sh |-- dot sh P.
Proof. intros. apply diamond_WN. trivial. Qed.

Lemma dot_K: forall sh (P Q : A),
  dot sh (P --> Q) |-- dot sh P --> dot sh Q.
Proof. intros. apply diamond_K. Qed.

Lemma dot_notp: forall sh (P : A),
  dot sh (!P) |-- ! (dot sh P).
Proof. intros. apply diamond_notp1. Qed.

Lemma dot_top: forall P,
  dot pfullshare P = P.
Proof. intro. apply diamond_T_eq. Qed.

Lemma dot_emp: forall sh,
  dot sh Emp = Emp.
Proof. intros. rewrite <- (andp_TT Emp). apply dot_prop. Qed.

Lemma dot_dot : forall sh1 sh2 P,
  dot sh1 (dot sh2 P) = dot (pbow sh2 sh1) P.
Proof. intros. etransitivity. symmetry. apply seqR_diamond. rewrite factorR_seqR. trivial. Qed.

Lemma dot_plus: forall P, precise P -> forall sh1 sh2 sh3, join sh1 sh2 sh3 ->
                dot sh3 P = (dot sh1 P) * (dot sh2 P).
Proof. intros. apply pred_ext. apply dot_plus1; trivial. apply dot_plus2; trivial. Qed.

Lemma uniform_prop: forall pi P,
  !!! P |-- (uniform pi).
Proof.
  intros.
  apply andp_left1.
  apply uniform_emp.
Qed.

Lemma uniform_star: forall pi P Q,
      P    |-- uniform pi ->
      Q    |-- uniform pi ->
    P * Q  |-- uniform pi. (* note, we only have one way here *)
Proof.
  intros. rewrite <- star_uniform.
  apply sepcon_derives; trivial.
Qed.

End SSL_ProofTheory.

Section FIL_ProofTheory.

Context {A RT : Type}.
Context {ND : NatDed A}.
Context {CND : @ClassicNatDed A ND}.
Context {SL : @SepLog A ND}.
Context {CSL : @ClassicalSep A ND SL}.
Context {PSL : @PreciseSepLog A ND SL}.
Context {ML : @ModLog RT A ND}.
Context {MLS : @ModLogSeq RT A ND ML}.
Context {SSL : @ScaledSepLog A RT ND SL PSL ML MLS}.
Context {FIL : @FracIndLog A RT ND SL PSL ML MLS SSL}.

Lemma shrinking_within: forall P sh,
  shrinking sh (within P) = shrinking sh P.
Proof.
  intros.
  unfold shrinking, within.
  rewrite <- seqR_box.
  rewrite shrinkingR_withinR. trivial.
Qed.

Lemma within_shrinking: forall P sh,
  within (shrinking sh P) = shrinking sh P.
Proof.
  intros.
  unfold shrinking, within.
  rewrite <- seqR_box.
  rewrite withinR_shrinkingR. trivial.
Qed.

Lemma within_star: forall P,
  within P |-- (within P) * (within P).
Proof.
  intros.
  rewrite <- (TT_andp (within P)) at 1.
  rewrite <- TT_sepcon_TT.
  eapply derives_trans.
  apply conj_within_star.
  apply sepcon_derives; apply andp_left2; trivial.
Qed.

Lemma shrinking_star: forall sh P,
  shrinking sh P |-- (shrinking sh P) * (shrinking sh P).
Proof.
  intros.
  rewrite <- within_shrinking.
  apply within_star.
Qed.

Lemma conj_shrinking_star2:forall P Q R sh,
  Q |-- uniform sh && !Emp ->
  (P * Q) && (shrinking sh R) |-- (P && R) * (Q && shrinking sh R).
Proof.
  intros.
  rewrite sepcon_comm. rewrite (sepcon_comm (P && R)).
  apply conj_shrinking_star1. trivial.
Qed.

Lemma conj_shrinking_entailswithin: forall P Q R S T sh,
  P |-- uniform sh && !Emp ->
  P && shrinking sh R |-- S ->
  Q && within R |-- T ->
  (P * Q) && shrinking sh R |-- S * T.
Proof.
  intros.
  rewrite <- shrinking_within.
  eapply derives_trans.
  apply conj_shrinking_star1. trivial.
  apply sepcon_derives; trivial.
  rewrite shrinking_within. trivial.
Qed.

Lemma conj_shrinking_entailswithin_uniform: forall P Q R sh,
  P |-- uniform sh && !Emp ->
  Q && within R |-- uniform sh ->
  (P * Q) && shrinking sh R |-- uniform sh.
Proof.
  intros.
  rewrite <- star_uniform.
  apply conj_shrinking_entailswithin; trivial.
  apply andp_left1. eapply derives_trans. apply H. apply andp_left1. trivial.
Qed.

End FIL_ProofTheory.

Section CSL_ProofTheory.

Context {A : Type}.
Context {ND : NatDed A}.
Context {CND : @ClassicNatDed A ND}.
Context {SL : @SepLog A ND}.

Lemma covariant_orp {B} : forall (P Q : (B -> A) -> (B -> A)),
  covariant P ->
  covariant Q ->
  covariant (fun F b => P F b || Q F b).
Proof.
  unfold covariant. intros.
  simpl. intro b.
  apply orp_left.
  apply orp_right1, H; trivial.
  apply orp_right2, H0; trivial.
Qed.

Lemma covariant_const {B} : forall P : (B -> A),
  covariant (fun _ b => P b).
Proof.
  unfold covariant. intros.
  simpl. intro b.
  apply derives_refl.
Qed.

Lemma covariant_exp {B} {C} : forall F : C -> (B -> A) -> (B -> A),
  (forall c, covariant (F c)) ->
  covariant (fun P b => EX c : C, F c P b).
Proof.
  repeat intro.
  apply exp_left. intro c.
  apply exp_right with c.
  apply H.
  apply H0.
Qed.

Lemma covariant_sepcon {B} : forall P Q : (B -> A) -> (B -> A),
  covariant P ->
  covariant Q ->
  covariant (fun F b => P F b * Q F b).
Proof.
  repeat intro.
  apply sepcon_derives.
  apply H. trivial.
  apply H0. trivial.
Qed.

Lemma covariant_const' {B} : forall b : B,
  covariant (fun P _ => P b).
Proof.
  repeat intro.
  apply H.
Qed.

End CSL_ProofTheory.


Require Import Reasoning.
Require Import Hask.Control.Iso.
Require Import Hask.Prelude.
Require Import Data.Either.
Require Import Data.Monoid.
Require Import Data.Functor.
Require Import Data.Functor.Contravariant.
Require Import Control.Applicative.
(* Require Import Data.Over. *)
Require Import Coq.Strings.String.
Require Import Coq.Setoids.Setoid.
Require Import Coq.Classes.Morphisms.
Require Import Classes.Morphisms_Prop.
Require Import FunctionalExtensionality.

Set Universe Polymorphism.

Generalizable All Variables.
(* Functors preserve extensional equality for the applied function.
   This is needed to perform setoid rewriting within the function
   passed to a functor. *)
Add Parametric Morphism {A B} `{Functor F} : (@fmap F _ A B)
  with signature (pointwise_relation _ eq ==> eq ==> eq)
    as mul_isomorphism.
Proof.
  intros.
  f_equal.
  extensionality e.
  apply H0.
Qed.

Print nat_ind.
Print nat_rect.

(* Polymorphic Cumulative *)
Inductive FreeA (f : Set -> Set) (a : Set) :=
    Pure : a -> FreeA f a
  | MkAp : forall b, f (b -> a) -> FreeA f b -> FreeA f a.

Arguments Pure {f} {a}.
Arguments MkAp {f} {a} {b}.

Check FreeA_ind.

Fixpoint FreeA_map {A B : Set} `{Functor F}
           (g : (A -> B)) (a : FreeA F A) : FreeA F B :=
  match a with
  | Pure x   => Pure (g x)
  | MkAp h x => MkAp (fmap (fun k : _ -> A => g \o k) h) x
  end.

Program Instance FreeA_Functor (F : Set -> Set)
  (HF : Functor F) : Functor (FreeA F) := {
  fmap := fun _ _ f x => FreeA_map f x
}.

Import FunctorLaws.

Lemma fmap_rewrite_compose {A B C : Set} `{Functor F} :
  forall (f : B -> C) (g : A -> B) (x : F A),
    fmap f (fmap g x) = (fmap f \o fmap g) x.
Proof.
  intros f g x.
  reflexivity.
Qed.

Program Instance FreeA_FunctorLaws
  (F : Set -> Set) (HF : Functor F) (HFL : FunctorLaws F) : FunctorLaws (FreeA F).
(* Theorem FreeA_Functor_law1 {A : Set} *)
(*         `{Functor F} `{FunctorLaws F} : *)
(*   forall (x : FreeA F A), fmap id x = id x. *)
Obligation 1.
Proof.
extensionality x.
revert x.
induction x; simpl in *; trivial.
- now rewrite fmap_id.
Defined.
Obligation 2.
extensionality x.
induction x; simpl in *; trivial.
- f_equal.
  rewrite fmap_rewrite_compose.
  now rewrite fmap_comp.
Defined.

Fixpoint FreeA_depth {A : Set} `{Functor F}
         (x : FreeA F A) : nat :=
  match x with
  | Pure a   => O
  | MkAp _ y => S (FreeA_depth y)
  end.

Lemma FreeA_fmap_preserves_depth {A B : Set} `{Functor F} :
  forall (x : FreeA F A) (f : A -> B),
  FreeA_depth (FreeA_map f x) = FreeA_depth x.
Proof.
  induction x; trivial.
Qed.

From Equations Require Import Equations.

Equations FreeA_ap {A B : Set} `{Functor F}
         (k : FreeA F (A -> B)) (y : FreeA F A) : FreeA F B by wf (FreeA_depth k) :=
FreeA_ap (Pure g) y := g <$> y;
FreeA_ap (MkAp h x) y := MkAp (fmap uncurry h) (FreeA_ap (fmap pair x) y).
Obligation 1.
Proof.
  rewrite FreeA_fmap_preserves_depth. auto.
Defined.
Transparent FreeA_ap_unfold.

Program Instance FreeA_Applicative
  {F : Set -> Set} {HF : Functor F} : Applicative (FreeA F) := {
  pure _ x := Pure x;
  ap _ _ k y := FreeA_ap k y
}.

Import ApplicativeLaws.

Print FreeA_ind.

Lemma lemma1_pure {A B C : Set} `{Functor F} `{FunctorLaws F} :
  forall (u : B -> C) (f : A -> B) (x : FreeA F A),
    fmap u (Pure f <*> x) = fmap (fun k : A -> B => u \o k) (Pure f) <*> x.
Proof.
  intros u f x.
  simpl "<*>".
  repeat rewrite FreeA_ap_equation_1.
  now rewrite <- fmap_comp.
Qed.

Lemma uncurry_l_1 {A B C : Set} :
  forall (f : A -> B -> C) (g : A * B -> C) (x : A) (y : B),
    f x y = g (pair x y) -> (uncurry f) (pair x y) = g (pair x y).
Proof.
  intros f g x y H.
  unfold uncurry. simpl. apply H.
Qed.

Theorem FreeA_ap_fmap :
  forall (A B : Set) (F : Set -> Set) (HF : Functor F)
    (x : FreeA F A) (f : A -> B),
    pure[FreeA F] f <*> x = fmap f x.
Proof.
  intros A B F HF x f.
  induction x;
  simpl; simp FreeA_ap; now simpl.
Qed.

Module FreeA_Parametricity.
Import ContravariantLaws.

Inductive F1 (F : Set -> Set) (A X : Set) := MkF1 : F (X -> A) -> F1 F A X.

Program Instance F1_Contravariant
  (F : Set -> Set) (HF : Functor F) (A : Set)  :
  Contravariant (F1 F A) := {
  contramap := fun _ _ h x => match x with
                           | MkF1 _ _ _ g => MkF1 F A _ (fmap (fun k => k ∘ h) g)
                           end
}.

Program Instance F1_ContravariantLaws
  (F : Set -> Set) (HF : Functor F) (HFL : FunctorLaws F) (A : Set)  :
  ContravariantLaws (F1 F A).
Obligation 1.
extensionality x.
destruct x. rewrite fmap_id. now unfold id.
Qed.
Obligation 2.
extensionality x.
destruct x. simpl. f_equal. functor_laws.
Qed.

Inductive F2 (F : Set -> Set) (A X : Set) := MkF2 : (FreeA F X -> FreeA F A) -> F2 F A X.

Program Instance F2_Contravariant
  (F : Set -> Set) (HF : Functor F) (A : Set)  :
  Contravariant (F2 F A) := {
  contramap := fun _ _ h x => match x with
                           | MkF2 _ _ _ g => MkF2 F A _ (g ∘ fmap h)
                           end
}.

Program Instance F2_ContravariantLaws
  (F : Set -> Set) (HF : Functor F) (HFL : FunctorLaws F) (A : Set)  :
  ContravariantLaws (F2 F A).
Obligation 1.
extensionality x. destruct x.
specialize (@fmap_id (FreeA F) (FreeA_Functor F HF)
                     (FreeA_FunctorLaws _ _ _)) as FreeA_map_id.
simpl in FreeA_map_id.
rewrite FreeA_map_id. unfold id. f_equal.
Qed.
Obligation 2.
extensionality x.
destruct x. simpl. f_equal.
specialize (@fmap_comp (FreeA F) (FreeA_Functor F _)
                       (FreeA_FunctorLaws _ _ _)) as FreeA_map_comp.
simpl in FreeA_map_comp.
now rewrite <- FreeA_map_comp.
Qed.

(**
  <*> is a natural transformation between contravariant functor F1 and F2
  https://arxiv.org/pdf/1403.0749.pdf (Section 4 : Parametricity)
*)
(* ∀g ::f (y → a),u ::FreeA f x. *)
(* fmap ( ◦ h) g :$:u ≡ g :$:fmap h u *)

Theorem FreeA_free_theorem :
  forall (A B X : Set) (F : Set -> Set) (HF : Functor F)
    (f : A -> B) (h : X -> B) (g : FreeA F (B -> X)) (u : FreeA F X),
    (fmap[FreeA F] (fun k => k ∘ h) g) <*> u = g <*> fmap h u.
Admitted.
Theorem FreeA_free_theorem_1 :
  forall (A B C : Set) (F : Set -> Set) (HF : Functor F)
    (f : A -> B) (g : B -> C)
    (x : FreeA F A) (y : FreeA F (A -> B)) (h : (A -> B) -> (B -> C)),
    g <$> (y <*> x) = (h <$> y) <*> (f <$[FreeA F]> x).
Admitted.

End FreeA_Parametricity.

Theorem FreeA_free_1_MkAp :
  forall (A X Y : Set) (F : Set -> Set) (HF : Functor F)
    (h : X -> Y) (g : F (Y -> A)) (u : FreeA F X),
    MkAp (fmap[F] (fun k => k ∘ h) g) u = MkAp g (fmap h u).
Admitted.

Lemma K_and_K_lemma1 :
  forall (X Y Z : Set) (F : Set -> Set) (HF : Functor F) (HFL : FunctorLaws F)
  (u : Y -> Z)
  (v : FreeA F (X -> Y))
  (x : FreeA F X),
  fmap u (v <*> x) = fmap (fmap[→_] u) v <*> x.
Proof.
  intros X Y Z F HF HFL u v x.
  destruct v as [ v | g y ].
  -`Begin
   (fmap u (pure v <*> x)).
  ≡⟨ reflexivity ⟩
   (fmap u (fmap v x)).
  ≡⟨ functor_laws ⟩
   (fmap (u ∘ v) x).
  ≡⟨ functor_laws ⟩
   ((pure (u ∘ v) <*> x)).
  ≡⟨ functor_laws ⟩
   ((fmap (fmap[→_] u) (pure v)) <*> x)
  `End.
  -`Begin
    (fmap u (MkAp y v <*> x)).
  ≡⟨ now (simpl; simp FreeA_ap) ⟩
   (MkAp (fmap (fmap[→_] u) (fmap uncurry y))
         ((pair <$> v) <*> x)).
  ≡⟨ functor_laws ⟩
   (MkAp (fmap (fmap[→_] u ∘ uncurry) y)
         ((pair <$> v) <*> x)).
  ≡⟨ f_equal ⟩
   (MkAp (fmap[ F] (uncurry ∘ (fun k => (fun g0 => u ∘ g0) ∘  k)) y)
         ((pair <$> v) <*> x)).
  ≡⟨ functor_laws ⟩
   (MkAp (fmap[ F] uncurry (fmap[ F] (fun k => (fun g0 => u ∘ g0) ∘  k) y))
         ((pair <$> v) <*> x)).
  ≡⟨ now (simpl; simp FreeA_ap) ⟩
   (fmap (fmap[→_] u) (MkAp y v) <*> x)
  `End.
Qed.

Theorem FreeA_ApplicativeLaws_composition :
  forall (A B C : Set) (F : Set -> Set) (HF : Functor F) (HFL : FunctorLaws F)
  (u : FreeA F (B -> C)) (v : FreeA F (A -> B)) (w : FreeA F A),
  pure comp <*> u <*> v <*> w = u <*> (v <*> w).
Proof.
  intros A B C F HF HFL u v w.
  generalize dependent C. generalize dependent B. generalize dependent A.
  induction w.
  - admit.
  - intros.
  `Begin
   ((pure[ FreeA F]) comp <*> u <*> v <*> MkAp f w).
  ≡⟨ functor_laws ⟩
   (((comp <$> u) <*> v) <*> MkAp f w).
  simpl. simp FreeA_ap.
  ≡⟨ admit ⟩
   (u <*> (v <*> MkAp f w))
  `End.

Theorem FreeA_ApplicativeLaws_interchange :
  forall (A B : Set) (F : Set -> Set) (HF : Functor F)
    (u : FreeA F (A -> B)) (y : A),
    u <*> pure y = pure (rev_f_ap y) <*> u.
Proof.
  intros A B F HF u y.
  destruct u as [ f | X v g ].
  - simpl. now simp FreeA_ap.
  -
  `Begin
   (MkAp v g <*> pure y).
  ≡⟨ reflexivity ⟩
   (FreeA_ap (MkAp v g) (pure y)).
  ≡⟨ now rewrite FreeA_ap_equation_2 ⟩
   (MkAp (fmap uncurry v) ((fmap pair g) <*> pure y)).
  ≡⟨ admit ⟩
   (MkAp (fmap[F] (fun k => rev_f_ap y ∘ k) v) g).
  ≡⟨ reflexivity ⟩
    (fmap (rev_f_ap y) (MkAp v g)).
  ≡⟨ now rewrite FreeA_ap_fmap ⟩
    (pure (rev_f_ap y) <*> MkAp v g)
  `End.
    simpl. simp FreeA_ap. simpl.
Lemma lemma1_ap {A B C b : Set} `{Functor F} `{FunctorLaws F} :
  forall (u : B -> C) (v : FreeA F b) (f : F (b -> A -> B)) (x : FreeA F A),
         (* (IH : forall (g : FreeA F (b -> A -> B)), fmap u (g <*> v) = fmap (fun k : A -> B => u \o k) g <*> v), *)
    fmap u (MkAp f v <*> x) = fmap (fun k : A -> B => u \o k) (MkAp f v) <*> x.
Proof.
  intros u v f x.
  simpl "<*>".
  repeat rewrite (FreeA_ap_equation_2). simpl.
  (* Peel of the MkAp constructor *)
  f_equal.
  (* Now we need to use f_equal again to get read of the outer fmap [ F],
     but first we need to massage the fmap's arguments in a form that uses explicit
     function composition \o.*)
  remember (fun k : b * A -> B => u \o k) as p.
  remember (fun k : b -> A -> B => (fun k0 : A -> B => u \o k0) \o k) as q.
  assert (Htemp: fmap[ F] uncurry (fmap[ F] q f) = fmap[ F] (uncurry \o q) f).
  { now rewrite <- fmap_comp. } rewrite Htemp. clear Htemp.
  assert (Htemp : fmap[ F] p (fmap[ F] uncurry f) = fmap[ F] (p \o uncurry) f).
  { now rewrite <- fmap_comp. } rewrite Htemp. clear Htemp.
  f_equal.
  extensionality z.
  (* Now we need to prove (p \o uncurry) = (uncurry \o q), which, I suppose, should be
     our inductive hypothesis (if we actually did induction). *)
Admitted.

(* ∀g :: f (y → a), u :: FreeA f x. *)
(* fmap ( ◦ h) g :$: u ≡ g :$: fmap h  *)
Lemma lemma1 {A B C : Set} `{Functor F} :
  forall (u : B -> C) (v : FreeA F (A -> B)) (x : FreeA F A),
    fmap u (v <*>x) = fmap (fun k : A -> B => u \o k) v <*> x.
Proof.
  intros u v x.
  destruct v.
  - simpl. admit.
  - intros.
  induction v.
  pose (Statement := fun (v0 : FreeA F (A -> B)) =>
    forall x : FreeA F A,
    fmap u (v0 <*> x) =
    fmap (fun k : A -> B => u \o k) v0 <*> x
       ).
  Locate "<**>".
Abort.

Program Instance FreeA_ApplicativeLaws
  `{FunctorLaws F} :
  ApplicativeLaws (FreeA F).
Obligation 1.
(* ap_id *)
(* ap (pure id) = id *)
(* FreeA_ap (Pure id) y) = idtac *)
extensionality y.
induction y.
- reflexivity.
- rewrite FreeA_ap_equation_1.
  now rewrite fmap_id.
Defined.
Obligation 2.
generalize dependent c. generalize dependent b. generalize dependent a.
induction w.
- intros. repeat simp FreeA_ap. f_equal.
(* ap_comp : forall (a b c : TYpe) (v : f (a -> b)) (u : f (b -> c)) (w : f a), *)
(*     pure (fun f g x => f (g x)) <*> u <*> v <*> w = u <*> (v <*> w); *)
(* FreeA_ap *)
(*   (FreeA_ap (FreeA_ap (Pure (fun f g x => f (g x))) u) v) w = *)
(* FreeA_ap u (FreeA_ap v w) *)
rewrite FreeA_ap_equation_1.
(* remember (fmap[ FreeA F] (fun (f : b -> c) (g : a -> b) (x : a) => f (g x)) u) as t. *)
induction w.
- simpl.
Obligation 4.
admit.

(* pose (goal := fun u => FreeA_ap u (Pure y) = FreeA_ap (Pure (fun f : a -> b => f y)) u). *)
(* refine (FreeA_ind F goal _ _). *)


(***************************************************************************
* Safety for STLC with Patterns - Infrastructure                          *
* Arthur Chargueraud, July 2007                                            *
***************************************************************************)

Set Implicit Arguments.
Require Import List LibLN STLC_PatOpen_Definitions.

(* ********************************************************************** *)
(** ** Additional Definitions used in the Proofs *)

(** Computing free variables of a term. *)

Fixpoint fv (t : trm) {struct t} : vars :=
  match t with
  | trm_bvar i j  => \{}
  | trm_fvar x    => \{x}
  | trm_abs t1    => (fv t1)
  | trm_let p1 t1 t2 => (fv t1) \u (fv t2)
  | trm_app t1 t2 => (fv t1) \u (fv t2)
  | trm_pair t1 t2 => (fv t1) \u (fv t2)
  end.

(** Computing free variables of a list of terms. *)

Definition fv_list :=
  List.fold_right (fun t acc => fv t \u acc) \{}.

(** Free variables of the default term. *)

Lemma trm_def_fresh : fv trm_def = \{}.
Proof.
  auto.
Qed.

(** Substitution for names *)

Fixpoint subst (m : inst) (t : trm) {struct t} : trm :=
  match t with
  | trm_bvar i j  => t
  | trm_fvar x    => match get x m with Some t1 => t1 | None => t end
  | trm_abs t1    => trm_abs (subst m t1)
  | trm_let p1 t1 t2 => trm_let p1 (subst m t1) (subst m t2)
  | trm_app t1 t2 => trm_app (subst m t1) (subst m t2)
  | trm_pair t1 t2 => trm_pair (subst m t1) (subst m t2)
  end.

(** Predicate caraterizing lists of a given number of terms *)

Definition terms := list_for_n term.

(** Iterated typing *)

Definition typings (E : env) (m : inst) (M : environment typ) :=
  forall x t, binds x t m ->
  exists T, binds x T M /\ typing E t T.

(* ********************************************************************** *)
(** ** Instanciation of Tactics *)

Ltac gather_vars :=
  let A := gather_vars_with (fun x : vars => x) in
  let B := gather_vars_with (fun x : var => \{x}) in
  let C := gather_vars_with (fun x : env => dom x) in
  let D := gather_vars_with (fun x : trm => fv x) in
  let E := gather_vars_with (fun x : list trm => fv_list x) in
  constr:(A \u B \u C \u D \u E).

Ltac pick_fresh Y :=
  let L := gather_vars in (pick_fresh_gen L Y).

Ltac pick_freshes n Y :=
  let L := gather_vars in (pick_freshes_gen L n Y).

Tactic Notation "apply_fresh" constr(T) :=
  apply_fresh_base T gather_vars ltac_no_arg.

Tactic Notation "apply_fresh" "*" constr(T) :=
  apply_fresh T; autos*.

Tactic Notation "apply_fresh" constr(T) "as" ident(X) :=
  apply_fresh_base T gather_vars X.

Tactic Notation "apply_fresh" "*" constr(T) "as" ident(X) :=
  apply_fresh T as X; autos*.

Hint Constructors term value red typing pat_match pat_typing.

Hint Extern 1 (_ \notin fv trm_def) =>
  rewrite trm_def_fresh.

Hint Extern 1 (terms _ _) => split; auto.

Hint Extern 1 (fresh (dom (_ & _)) _ _) => simpl_dom.
(* todo: move *)

(* BIN!!
(* ********************************************************************** *)
(** ** Properties of iterated operators *)

Lemma fv_list_map : forall ts1 ts2,
  fv_list (ts1 ++ ts2) = fv_list ts1 \u fv_list ts2.
Proof.
  induction ts1; simpl; intros.
  rewrite* union_empty_l.
  rewrite IHts1. rewrite* union_assoc.
Qed.

Lemma typings_concat : forall E ts1 Us1 ts2 Us2,
  typings E ts1 Us1 ->
  typings E ts2 Us2 ->
  typings E (ts1++ts2) (Us1++Us2).
Proof.
  induction ts1; introv Typ1 Typ2; inversions Typ1; simpls*.
Qed.

(* ********************************************************************** *)
(** ** Properties of substitution *)

(** Substitution on indices is identity on well-formed terms. *)

Lemma open_rec_term_core :forall t j v i u, i <> j ->
  {j ~> v}t = {i ~> u}({j ~> v}t) -> t = {i ~> u}t.
Proof.
  induction t; introv Neq Equ;
  simpl in *; inversion* Equ; f_equal*.
  case_nat*. case_nat*.
Qed.

Lemma open_rec_term : forall t u,
  term t -> forall k, t = {k ~> u}t.
Proof.
  induction 1; intros; simpl; f_equal*.
  pick_fresh x. forwards~ K: (H0 x).
   apply* (@open_rec_term_core t1 0 (trm_fvars (x::nil))).
  pick_freshes (pat_arity p1) xs. forwards~ K: (H1 xs).
   apply* (@open_rec_term_core t2 0 (trm_fvars xs)).
  unfolds~ opens. (* todo : was not needed *)
Qed.

(** Substitution for a fresh name is identity. *)

Lemma subst_fresh : forall x t u,
  x \notin fv t ->
  [x ~> u] t = t.
Proof.
  intros. induction t; simpls; f_equal*.
  case_var*. notin_false.
Qed.

Lemma subst_fresh_list : forall z u ts,
  z \notin fv_list ts ->
  ts = List.map (subst z u) ts.
Proof.
  induction ts; simpl; intros Fr.
  auto. f_equal. rewrite~ subst_fresh. auto.
Qed.

Lemma subst_fresh_trm_fvars : forall z u xs,
  fresh (\{z}) (length xs) xs ->
  trm_fvars xs = List.map (subst z u) (trm_fvars xs).
Proof.
  intros. apply subst_fresh_list.
  induction xs; simpls. auto.
    destruct H. notin_solve. auto.
Qed.

Lemma substs_fresh : forall xs us t,
  fresh (fv t) (length xs) xs ->
  substs xs us t = t.
Proof.
  induction xs; simpl; intros us t Fr.
  auto. destruct us. auto.
  inversions Fr. rewrite* subst_fresh.
Qed.

(** Substitution distributes on the open operation. *)

Lemma subst_open : forall x u t1 t2, term u ->
  [x ~> u] (t1 ^^ t2) = ([x ~> u]t1) ^^ (List.map (subst x u) t2).
Proof.
  intros. unfold open, opens. simpl. generalize 0.
  induction t1; intros; simpl; f_equal*.
  case_nat*. unfold trm_nth.
   apply list_map_nth. apply* subst_fresh.
  case_var*. apply* open_rec_term.
Qed.

(** Substitution and open_var for distinct names commute. *)

Lemma subst_open_vars : forall x ys u t,
  fresh \{x} (length ys) ys ->
  term u ->
  ([x ~> u]t) ^ ys = [x ~> u] (t ^ ys).
Proof.
  introv Fr Tu. rewrite* subst_open.
  unfold trm_fvars. fequals.
  induction ys; simpls. auto.
  destruct Fr. case_var.
    notin_false. fequals~.
Qed.

(** Opening up an abstraction of body t with a term u is the same as opening
  up the abstraction with a fresh name x and then substituting u for x. *)

Lemma substs_intro_ind : forall t xs us vs,
  fresh (fv t \u fv_list vs \u fv_list us) (length xs) xs ->
  terms (length xs) us ->
  terms (length vs) vs ->
  t ^^ (vs ++ us) = substs xs us (t ^^ (vs ++ (trm_fvars xs))).
Proof.
  induction xs; simpl; introv Fr Tu Tv;
   destruct Tu; destruct us; tryfalse.
  auto.
  inversions H0. destruct Fr as [Fra Frb]. simpls.
  rewrite app_last.
  forwards K: (IHxs us (vs++t0::nil)); clear IHxs.
    rewrite* fv_list_map.
    auto.
    split~. inversions Tv. apply* Forall_app.
  rewrite K. clear K.
  f_equal. rewrite~ subst_open. rewrite~ subst_fresh.
  f_equal. rewrite map_app.
  simpl. case_var; tryfalse*.
  rewrite <- app_last.
  fequals. apply~ subst_fresh_list.
  fequals. apply* subst_fresh_trm_fvars.
Qed.

Lemma substs_intro : forall xs t us,
  fresh (fv t \u fv_list us) (length xs) xs ->
  terms (length xs) us ->
  t ^^ us = substs xs us (t ^ xs).
Proof.
  intros. apply* (@substs_intro_ind t xs us nil).
Qed.

(* ********************************************************************** *)
(** ** Terms are stable through substitutions *)

(** Terms are stable by substitution *)

Lemma subst_term : forall t z u,
  term u -> term t -> term ([z ~> u]t).
Proof.
  induction 2; simple*.
  case_var*.
  apply_fresh term_abs. rewrite* subst_open_vars.
  apply_fresh* term_let. rewrite* subst_open_vars.
Qed.

Hint Resolve subst_term.

(** Terms are stable by iterated substitution *)

Lemma substs_terms : forall xs us t,
  terms (length xs) us ->
  term t ->
  term (substs xs us t).
Proof.
  induction xs; destruct us; introv TU TT; simpl; auto.
  inversions TU. simpls. inversions H. inversions* H0.
Qed.
*)

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

Axiom subst_intro : forall xs t us,
  fresh (fv t \u fv_list us) (length xs) xs ->
  terms (length xs) us ->
  t ^^ us = subst (xs ~* us) (t ^ xs).

Axiom subst_terms : forall xs us t,
  terms (length xs) us ->
  term t ->
  term (subst (xs ~* us) t).

Axiom subst_open_vars : forall (m:inst) t ys,
  (* fresh \{x} l (elements (dom m)) ->   l = length dom m *)
  (* terms in m *)
  (subst m t) ^ ys = subst m (t ^ ys).

(* ********************************************************************** *)
(** ** Terms are stable through open *)

(** Conversion from locally closed abstractions and bodies *)

Lemma term_abs_to_body : forall t1,
  term (trm_abs t1) -> bodys 1 t1.
Proof.
  intros. unfold bodys. inversions* H.
  exists L. intros.
  destruct xs; simpl in H; destruct H.
  destruct xs; simpl in H0; destruct H0. auto.
Qed.

Lemma body_to_term_abs : forall t1,
  bodys 1 t1 -> term (trm_abs t1).
Proof.
  destruct 1. apply_fresh* term_abs.
Qed.
Lemma term_let_to_body : forall p1 t1 t2,
  term (trm_let p1 t1 t2) -> bodys (pat_arity p1) t2.
Proof.
  intros. unfold bodys. inversions* H.
Admitted. (* todo: fresh *)

Lemma body_to_term_let : forall p1 t1 t2,
  pattern p1 -> term t1 -> bodys (pat_arity p1) t2 ->
  term (trm_let p1 t1 t2).
Proof.
  destruct 3. apply_fresh* term_let.
Qed.

Hint Resolve body_to_term_abs term_abs_to_body
             body_to_term_let.

Hint Extern 1 (bodys (pat_arity ?p1) ?t2) =>
  match goal with H: context [trm_let p1 ?t1 t2] |- _ =>
    apply (@term_let_to_body p1 t1 t2) end.

(** ** Opening a body with a term gives a term *)

Lemma open_terms : forall t (us:list trm),
  bodys (length us) t ->
  terms (length us) us ->
  term (t ^^ us).
Proof.
  introv [L K] WT. pick_freshes (length us) xs. lets Fr': Fr.
  rewrite (fresh_length Fr) in WT, Fr'.
  rewrite* (@subst_intro xs). apply* subst_terms.
Qed.

Hint Resolve open_terms.

(* ********************************************************************** *)
(** ** Todo : renaming lemma for pat_match *)

(*
Fixpoint pat_subst (m : environment var) (p : pat) {struct p} : pat :=
  match p with
  | pat_fvar x     => If x = z then u else (pat_fvar x)
  | pat_bvar n     => pat_bvar n
  | pat_wild       => pat_wild
  | pat_pair p1 p2 => pat_pair (pat_subst z u p1) (pat_subst z u p2)
  end.

Lemma pat_match_rename : forall p xs ys m T,
   pat_match p T m ->
   pat_match (pat_subst (xs~*ys) p) T (map_keys (xs~*ys) m).
Proof.
  induction p; introv P1 P2;
   inversions P1; inversions P2.
  skip.
  skip.
  skip.
  skip.
Qed.
*)

(* ********************************************************************** *)
(** ** Regularity of relations *)

Hint Constructors pat_binds.

Lemma pat_binds_fct : forall p s1 s2,
  pat_binds p s1 ->
  pat_binds p s2 ->
  s1 = s2.
Proof.
  introv Pat1. gen s2. induction Pat1; introv Pat2; inverts~ Pat2.
  rewrite (@IHPat1_1 _ H2). rewrite (@IHPat1_2 _ H3). auto.
Qed.

Lemma pat_typing_regular : forall E p T,
  E \= p ~: T -> pat_binds p (dom E).
Proof.
  introv H. induction H; simpl.
  rewrite~ union_empty_r.
  auto.
  rewrite~ dom_concat.
Qed.

(* typing relation holds only if the environment has no
   duplicated keys and the pre-term is locally-closed. *)

Lemma typing_regular : forall E e T,
  typing E e T -> ok E /\ term e.
Proof.
  split; induction* H.
  pick_fresh x. forwards~ K: (H0 x).
  apply_fresh* term_let as ys.
   exists L. intros ys Frys.
   forwards~ K: (H1 ys).
   forwards~ B: (pat_typing_regular K).
    rewrite~ dom_singles in B.
    rewrite~ <- (fresh_length Frys).
Qed.

(** The value predicate only holds on locally-closed terms. *)

Lemma value_regular : forall e,
  value e -> term e.
Proof.
  induction 1; autos*.
Qed.

(** Pattern-matching regular. *)

Lemma pat_match_regular : forall p t m,
  pat_match p t m ->
     pat_binds p (dom m)
  /\ term t
  /\ forall x t1, binds x t1 m -> term t1.
Proof.
  induction 1; (splits 3; [ | autos* | introv B ]).
  rewrite~ dom_single.
  destruct (binds_single_inv B). subst~.
  auto.
  false.
  rewrite* dom_concat.
  destruct* (binds_concat_inv _ _ B).
Qed.

Lemma terms_of_singles_terms : forall ys ts,
  fresh \{} (length ts) ys ->
  (forall (x:var) (t1:trm), binds x t1 (ys ~* ts) -> term t1) ->
  Forall term ts.
Proof.
  introv. gen ys. induction ts as [|t ts]; introv Fr Bind.
  auto.
  destruct ys as [|y ys]. false. simpl in Fr. destruct Fr.
   constructor. apply~ (@IHts ys).
     introv B. apply (@Bind x). skip: (x <> y).
      rewrite singles_cons. apply~ binds_push_neq.
(* TODO:
   x \in dom (ys ~* ts)
   x \in from_list ys
   since "disjoint \{y} ys"
   we deduce x <> y *)
     apply (@Bind y). rewrite singles_cons.
     apply binds_push_eq.
Qed.

(** A reduction relation only holds on pairs of locally-closed terms. *)

Lemma terms_trm_fvars : forall ys,
  terms (length ys) (trm_fvars ys).
Proof.
  intros ys. induction ys; try destruct IHys; split; simple~.
Qed.

Arguments fresh_length [xs] [L] [n].

Lemma red_regular : forall e e',
  red e e' -> term e /\ term e'.
Proof.
  induction 1; autos* value_regular.
  pick_freshes (pat_arity p1) xs.
  forwards~ K: (H2 xs).
  forwards~ [K1 K2] : (pat_match_regular K).
  split.
    apply_fresh* term_let as ys.
      exists L. intros ys Frys.
       forwards~ M: (H2 ys).
       lets B: (proj1 (pat_match_regular M)).
       rewrite~ dom_singles in B.
       rewrite~ <- (fresh_length Frys).
     lets Eq Terms:(terms_trm_fvars ys).
      apply~ open_terms. rewrite <- Eq.
       rewrite~ <- (fresh_length Frys).
   pick_freshes (length ts) ys.
    apply open_terms. rewrite~ H0.
    forwards~ M: (H2 ys).
    lets B: (proj33 (pat_match_regular M)).
    split~. apply~ (@terms_of_singles_terms ys).
Qed.

(** Automation for reasoning on well-formedness. *)

Hint Extern 1 (ok ?E) =>
  match goal with
  | H: typing E _ _ |- _ => apply (proj1 (typing_regular H))
  end.

Hint Extern 1 (term ?t) =>
  match goal with
  | H: typing _ t _ |- _ => apply (proj2 (typing_regular H))
  | H: red t _ |- _ => apply (proj1 (red_regular H))
  | H: red _ t |- _ => apply (proj2 (red_regular H))
  | H: value t |- _ => apply (value_regular H)
  end.

(* todo: ajouter pat_match_regular ?
Hint Extern 1 (pattern _) => skip.
*)