(* 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 general_Q.
Require Export positive_fraction_encoding.
Require Import Merge_Order.
Require Import Wf_nat.

Definition top_more (a b c d : Z) :=
  (c <= a)%Z /\ (d < b)%Z \/ (c < a)%Z /\ (d <= b)%Z.

Lemma top_more_informative :
 forall a b c d : Z, {top_more a b c d} + {~ top_more a b c d}.
Proof.
 intros.
 case (quadro_leq_inf a b c d).
 intro.
 elim a0.
 intros.
 case (Z_le_lt_eq_dec c a H).
 intro.
 left.
 right.
 split.
 assumption.
 assumption.
 intro.
 case (Z_le_lt_eq_dec d b H0).
 intro.
 left.
 left.
 split.
 assumption.
 assumption.
 intro.
 right.
 intro.
 case H1.
 intro.
 elim H2.
 intros.
 rewrite e0 in H4.
 apply (Zgt_irrefl b).
 Flip.
 intro.
 elim H2.
 intros.
 rewrite e in H3.
 apply (Zgt_irrefl a).
 Flip.

 unfold top_more in |- *.
 intro.
 right.
 intro.
 case H.
 intro.
 apply n.
 elim H0.
 intros.
 split.
 assumption.
 apply Zlt_le_weak.
 assumption.
 intro.
 apply n.
 elim H0.
 intros.
 split.
 apply Zlt_le_weak.
 assumption.
 assumption.
Defined.

Lemma top_more_1 :
 forall a b c d : Z, top_more a b c d -> (0 < a - c + (b - d))%Z.
Proof.
 intros.
 case H.
 intros.
 elim H0.
 intros.
 replace 0%Z with (0 + 0)%Z.
 apply Zplus_le_lt_compat.
 unfold Zminus in |- *.
 apply Zle_left.
 assumption.
 apply Zlt_minus.
 assumption.
 constructor.
 intro.
 elim H0.
 intros.
 replace 0%Z with (0 + 0)%Z.
 apply Zplus_lt_le_compat.
 apply Zlt_minus.
 assumption.
 unfold Zminus in |- *.
 apply Zle_left.
 assumption.
 constructor.
Defined.

Lemma top_more_2 : forall a b c d : Z, top_more a b c d -> (c + d < a + b)%Z.
Proof.
 intros.
 case H.
 intros.
 elim H0.
 intros.
 apply Zplus_le_lt_compat.
 assumption.
 assumption.
 intros.
 elim H0.
 intros.
 apply Zplus_lt_le_compat.
 assumption.
 assumption.
Defined.

Lemma top_more_3 :
 forall a b c d : Z, (0 < c + d)%Z -> (a - c + (b - d) < a + b)%Z.
Proof.
 intros.
 apply Zplus_lt_reg_l with (c + d)%Z.
 apply Zplus_lt_reg_l with (- a - b)%Z.
 replace (- a - b + (c + d + (a - c + (b - d))))%Z with 0%Z.
 replace (- a - b + (c + d + (a + b)))%Z with (c + d)%Z.
 assumption.
 ring.
 ring.
Defined.

Lemma top_more_4 : forall a b c d : Z, top_more a b c d -> (c <= a)%Z.
Proof.
 intros.
 case H.
 intros.
 elim H0.
 intros.
 assumption.
 intros.
 elim H0.
 intros.
 apply Zlt_le_weak.
 assumption.
Defined.

Lemma top_more_4' : forall a b c d : Z, top_more a b c d -> (d <= b)%Z.
Proof.
 intros.
 case H.
 intros.
 elim H0.
 intros.
 apply Zlt_le_weak.
 assumption.
 intros.
 elim H0.
 intros.
 assumption.
Defined.

Lemma top_more_5 :
 forall a b c d : Z,
 (0 < c + d)%Z -> (a - c + (b - d) + c + d < a + b + c + d)%Z.
Proof.
 intros.
 assert ((a - c + (b - d) + c + d)%Z = (a + b + 0)%Z).
 ring.
 rewrite H0.
 rewrite Zplus_assoc_reverse with (n := (a + b)%Z).
 apply Zplus_le_lt_compat.
 apply Z.le_refl.
 assumption.
Defined.

Lemma top_more_5' :
 forall a b c d : Z,
 (0 < a + b)%Z -> (a + b + (c - a) + (d - b) < a + b + c + d)%Z.
Proof.
 intros.
 assert ((a + b + (c - a) + (d - b))%Z = (0 + (c + d))%Z).
 ring.
 rewrite H0.
 rewrite Zplus_assoc_reverse with (n := (a + b)%Z).
 apply Zplus_lt_le_compat.
 assumption.
 apply Z.le_refl.
Defined.

Inductive homographicAcc : Z -> Z -> Z -> Z -> Qpositive -> Prop :=
  | homographicacc0 :
      forall (a b c d : Z) (p : Qpositive),
      p = One -> (0 < a + b)%Z -> (0 < c + d)%Z -> homographicAcc a b c d p
  | homographicacc1 :
      forall (a b c d : Z) (p : Qpositive),
      p <> One ->
      top_more a b c d ->
      homographicAcc (a - c)%Z (b - d)%Z c d p -> homographicAcc a b c d p
  | homographicacc2 :
      forall (a b c d : Z) (p : Qpositive),
      p <> One ->
      ~ top_more a b c d ->
      top_more c d a b ->
      homographicAcc a b (c - a)%Z (d - b)%Z p -> homographicAcc a b c d p
  | homographicacc3 :
      forall (a b c d : Z) (xs : Qpositive),
      ~ top_more a b c d ->
      ~ top_more c d a b ->
      homographicAcc a (a + b)%Z c (c + d)%Z xs ->
      homographicAcc a b c d (nR xs)
  | homographicacc3' :
      forall (a b c d : Z) (xs : Qpositive),
      ~ top_more a b c d ->
      ~ top_more c d a b ->
      homographicAcc (a + b)%Z b (c + d)%Z d xs ->
      homographicAcc a b c d (dL xs).

Lemma homographicacc_0_num :
 forall a b c d : Z, homographicAcc a b c d One -> (0 < a + b)%Z.
Proof.
 intros.
 abstract (inversion H; trivial; Irreflex; discriminate H0).
Defined.

Lemma homographicacc_0_denom :
 forall a b c d : Z, homographicAcc a b c d One -> (0 < c + d)%Z.
Proof.
 intros.
 abstract (inversion H; trivial; Irreflex; discriminate H0).
Defined.

Lemma homographicacc_1 :
 forall (a b c d : Z) (p : Qpositive),
 homographicAcc a b c d p ->
 p <> One -> top_more a b c d -> homographicAcc (a - c) (b - d) c d p.
Proof.
 simple destruct 1; intros; trivial; Falsum.
Defined.

Lemma homographicacc_2 :
 forall (a b c d : Z) (p : Qpositive),
 homographicAcc a b c d p ->
 p <> One ->
 ~ top_more a b c d ->
 top_more c d a b -> homographicAcc a b (c - a) (d - b) p.
Proof.
 simple destruct 1; intros; trivial; Falsum.
Defined.

Lemma homographicacc_3 :
 forall (a b c d : Z) (p : Qpositive),
 homographicAcc a b c d p ->
 forall xs : Qpositive,
 p = nR xs ->
 ~ top_more a b c d ->
 ~ top_more c d a b -> homographicAcc a (a + b) c (c + d) xs.
Proof.
 intros a b c d p HAcc; case HAcc; intros; try solve [ Falsum ];
  [ rewrite H2 in H; clear H2; discriminate H
  | let T_local := eval compute in (f_equal Qpositive_tail H2) in
    (rewrite <- T_local; assumption)
  | discriminate H2 ].
Defined.

Lemma homographicacc_3' :
 forall (a b c d : Z) (p : Qpositive),
 homographicAcc a b c d p ->
 forall xs : Qpositive,
 p = dL xs ->
 ~ top_more a b c d ->
 ~ top_more c d a b -> homographicAcc (a + b) b (c + d) d xs.
Proof.
 intros a b c d p HAcc xs.
 case HAcc; intros; try solve [ Falsum ];
  [ rewrite H2 in H; clear H2; discriminate H
  | discriminate H2
  | let T_local := eval compute in (f_equal Qpositive_tail H2) in
    (rewrite <- T_local; assumption) ].
Defined.

Fixpoint Qhomographic_Qpositive_to_Qpositive (a b c d : Z)
 (p : Qpositive) (hyp : homographicAcc a b c d p) {struct hyp} : Qpositive :=
  match Qpositive_dec_One p with
  | left H_p_is_One =>
      let H :=
        eq_ind p (fun p : Qpositive => homographicAcc a b c d p) hyp One
          H_p_is_One in
      (fun hyp0 : homographicAcc a b c d One =>
       (fun (Hab : (0 < a + b)%Z) (Hcd : (0 < c + d)%Z) =>
        positive_fraction_encoding (a + b) (c + d) Hab Hcd)
         (homographicacc_0_num a b c d hyp0)
         (homographicacc_0_denom a b c d hyp0)) H
  | right H_p_not_One =>
      match top_more_informative a b c d with
      | left H_abcd =>
          nR
            (Qhomographic_Qpositive_to_Qpositive (a - c)%Z
               (b - d)%Z c d p
               (homographicacc_1 a b c d p hyp H_p_not_One H_abcd))
      | right H_abcd =>
          match top_more_informative c d a b with
          | left H_cdab =>
              dL
                (Qhomographic_Qpositive_to_Qpositive a b
                   (c - a)%Z (d - b)%Z p
                   (homographicacc_2 a b c d p hyp H_p_not_One H_abcd H_cdab))
          | right H_cdab =>
              match p as q return (p = q -> Qpositive) with
              | nR q =>
                  fun H : p = nR q =>
                  Qhomographic_Qpositive_to_Qpositive a
                    (a + b)%Z c (c + d)%Z q
                    (homographicacc_3 a b c d p hyp q H H_abcd H_cdab)
              | dL q =>
                  fun H : p = dL q =>
                  Qhomographic_Qpositive_to_Qpositive
                    (a + b)%Z b (c + d)%Z d q
                    (homographicacc_3' a b c d p hyp q H H_abcd H_cdab)
              | One =>
                  fun q : p = One =>
                  False_rec Qpositive (False_ind False (H_p_not_One q))
              end (refl_equal p)
          end
      end
  end.

(** some sort of lexicographical order on binary lists *)

Fixpoint Qpositive_length (qp : Qpositive) : nat :=
  match qp with
  | One => 0
  | dL qp1 => S (Qpositive_length qp1)
  | nR qp1 => S (Qpositive_length qp1)
  end.

Definition bin_lt (qp1 qp2 : Qpositive) : Prop :=
  Qpositive_length qp1 < Qpositive_length qp2.

Definition bin_eq (x y : Qpositive) := x = y.

(* We mention the following form only for the proof of the well-foundedness  *)
Lemma bin_lt_compat_via_length :
 forall x y : Qpositive,
 bin_lt x y -> Qpositive_length x < Qpositive_length y.
Proof.
 trivial.
Defined.

Lemma compare_dL : forall x : Qpositive, bin_lt x (dL x).
Proof.
 unfold bin_lt in |- *.
 simpl in |- *.
 auto with arith.
Defined.

Lemma compare_nR : forall x : Qpositive, bin_lt x (nR x).
Proof.
 unfold bin_lt in |- *.
 simpl in |- *.
 auto with arith.
Defined.

(** Definition of order for quadroples and a binary sequnce *)

Record Z_pos : Set :=  {zposcrr :> Z; z4prf_Z_pos : (0 <= zposcrr)%Z}.

Definition qlt (a b c d : Z) (p : Qpositive) (a' b' c' d' : Z)
  (p' : Qpositive) : Prop :=
  bin_lt p p' \/ p = p' /\ (a + b + c + d < a' + b' + c' + d')%Z.

Definition qle (a b c d : Z) (p : Qpositive) (a' b' c' d' : Z)
  (p' : Qpositive) : Prop :=
  qlt a b c d p a' b' c' d' p' \/
  a = a' /\ b = b' /\ c = c' /\ d = d' /\ p = p'.

Definition quadrointegral_lt (a b c d a' b' c' d' : Z) :=
  (a + b + c + d < a' + b' + c' + d')%Z.

Definition quadrointegral_eq (a b c d a' b' c' d' : Z) :=
  a = a' /\ b = b' /\ c = c' /\ d = d'.

Record Z4 : Set :=
  {z4crr :> Z * Z * (Z * Z);
   z4prf :
    (0 <= fst (fst z4crr))%Z /\
    (0 <= snd (fst z4crr))%Z /\
    (0 <= fst (snd z4crr))%Z /\ (0 <= snd (snd z4crr))%Z}.

Definition Z4_lt (x y : Z4) :=
  let (V1, V2) := z4crr x in
  let (V3, V4) := z4crr y in
  let (a, b) := V1 in
  let (c, d) := V2 in
  let (a', b') := V3 in
  let (c', d') := V4 in quadrointegral_lt a b c d a' b' c' d'.

Definition Z4_eq (x y : Z4) :=
  let (V1, V2) := z4crr x in
  let (V3, V4) := z4crr y in
  let (a, b) := V1 in
  let (c, d) := V2 in
  let (a', b') := V3 in
  let (c', d') := V4 in quadrointegral_eq a b c d a' b' c' d'.

Lemma Z4_lt_is_irreflexive : forall x : Z4, ~ Z4_lt x x.
Proof.
 intros (((a, b), (c, d)), z4prf0).
 unfold Z4_lt in |- *.
 unfold quadrointegral_lt in |- *.
 simpl in |- *.
 apply Z.lt_irrefl.
Defined.

Lemma Z4_lt_is_transitive :
 forall x y z : Z4, Z4_lt x y -> Z4_lt y z -> Z4_lt x z.
Proof.
 intros (((a, b), (c, d)), z4prf0) (((a', b'), (c', d')), z4prf1)
  (((a2, b2), (c2, d2)), z4prf2).
 unfold Z4_lt in |- *.
 unfold quadrointegral_lt in |- *.
 simpl in |- *.
 intros.
 apply Z.lt_trans with (a' + b' + c' + d')%Z; assumption.
Defined.

Lemma Z4_lt_is_order : is_order Z4 Z4_lt.
Proof.
 split.
 apply Z4_lt_is_irreflexive.
 apply Z4_lt_is_transitive.
Defined.

Lemma Z4_eq_is_reflexive : forall x : Z4, Z4_eq x x.
Proof.
 intros (((a, b), (c, d)), z4prf0).
 unfold Z4_eq in |- *.
 unfold quadrointegral_eq in |- *; repeat split.
Defined.

Lemma Z4_eq_is_symmetric : forall x y : Z4, Z4_eq x y -> Z4_eq y x.
Proof.
 intros (((a, b), (c, d)), z4prf0) (((a', b'), (c', d')), z4prf1).
 unfold Z4_eq in |- *.
 unfold quadrointegral_eq in |- *.
 intros (HH1, (HH2, (HH3, HH4))); repeat split; symmetry  in |- *; assumption.
Defined.

Lemma Z4_eq_is_transitive :
 forall x y z : Z4, Z4_eq x y -> Z4_eq y z -> Z4_eq x z.
Proof.
 intros (((a, b), (c, d)), z4prf0) (((a', b'), (c', d')), z4prf1)
  (((a2, b2), (c2, d2)), z4prf2).
 unfold Z4_eq in |- *.
 unfold quadrointegral_eq in |- *.
 simpl in |- *.
 intros (HH2, (HH4, (HH6, HH7))) (HH9, (HH11, (HH13, HH14))); repeat split;
  match goal with
  | id12:(?X1 = ?X2),id23:(?X2 = ?X3) |- (?X1 = ?X3) =>
      try apply (trans_eq id12 id23)
  end.
Defined.

Lemma Z4_eq_is_equality : is_equality Z4 Z4_eq.
Proof.
 split.
 apply Z4_eq_is_reflexive.
 split.
 apply Z4_eq_is_symmetric.
 apply Z4_eq_is_transitive.
Defined.

Lemma Z_pos_lt_is_wf :
 forall P : Z_pos -> Prop,
 (forall q : Z_pos, (forall r : Z_pos, (r < q)%Z -> P r) -> P q) ->
 forall q : Z_pos, P q.
Proof.
 intros.
 destruct q.
 rename zposcrr0 into q.
 set (P2 := fun p : Z => forall Hp : (0 <= p)%Z, P (Build_Z_pos p Hp)) in *.
 assert (P2 q).
 apply Zind_wf with (p := 0%Z).
 intros.
 unfold P2 in |- *.
 intro.
 apply H.
 intros.
 destruct r.
 rename zposcrr0 into r.
 assert (P2 r).
 apply H0.
 split.
 assumption.
 assumption.
 apply (H2 z4prf_Z_pos1).
 assumption.
 apply (H0 z4prf_Z_pos0).
Defined.

Lemma Z4_lt_is_wf : wf_ind Z4 Z4_lt.
Proof.
 red in |- *.
 intros P H (((a, b), (c, d)), p); revert p;
 simpl in |- *.
 intros (Ha, (Hb, (Hc, Hd))).
 assert (H_a_b_c_d : (0 <= a + b + c + d)%Z); repeat apply Zplus_le_0_compat;
  try assumption.
 (* Here Omega tactic would have worked as opposed to the similar situation below *)
 set
  (P4 :=
   fun k : Z_pos =>
   forall (a b c d : Z)
     (Habcd : (0 <= a)%Z /\ (0 <= b)%Z /\ (0 <= c)%Z /\ (0 <= d)%Z)
     (Hk : zposcrr k = (a + b + c + d)%Z), P (Build_Z4 (a, b, (c, d)) Habcd))
  in *.
 assert (P4 (Build_Z_pos (a + b + c + d) H_a_b_c_d)).

 apply Z_pos_lt_is_wf.
 intros q_pos.
 red in |- *.
 intros.
 apply H.
 intros (((r_a, r_b), (r_c, r_d)), p); revert p.
 simpl in |- *.
 intros (H_r_a, (H_r_b, (H_r_c, H_r_d))).
 intro Hq.

 assert (H_r_a_b_c_d : (0 <= r_a + r_b + r_c + r_d)%Z);
  repeat apply Zplus_le_0_compat; try assumption.
 (* Here Omega tactic does not work, as if we say "Clear z4prf1" and gives an error! *)
 assert (P4 (Build_Z_pos (r_a + r_b + r_c + r_d) H_r_a_b_c_d)).

 apply H0.
 rewrite Hk.
 simpl in |- *.
 assumption.

 apply H1.
 reflexivity.
 apply H0.
 reflexivity.
Defined.

Lemma Z4_lt_is_well_def_rht : is_well_def_rht Z4 Z4_lt Z4_eq.
Proof.
 red in |- *.
 intros (((a, b), (c, d)), z4prf0) (((a', b'), (c', d')), z4prf1).
 intro H.
 intros (((a2, b2), (c2, d2)), z4prf2).
 generalize H.
 unfold Z4_lt in |- *.
 unfold Z4_eq in |- *.
 unfold quadrointegral_lt in |- *.
 unfold quadrointegral_eq in |- *.
 simpl in |- *.
 clear H z4prf0 z4prf1 z4prf2.
 intros H0 (H1, (H2, (H3, H4))).
 repeat
  match goal with
  | id:(?X1 = ?X2) |- _ => try rewrite id in H0; clear id
  end.
 assumption.
Defined.

Definition Z4_as_well_ordering :=
  Build_well_ordering Z4 Z4_lt Z4_eq Z4_lt_is_order Z4_eq_is_equality
    Z4_lt_is_wf Z4_lt_is_well_def_rht.

Lemma bin_lt_is_irreflexive : forall x : Qpositive, ~ bin_lt x x.
Proof.
 intros x.
 unfold bin_lt in |- *.
 apply lt_irrefl.
Defined.

Lemma bin_lt_is_transitive :
 forall x y z : Qpositive, bin_lt x y -> bin_lt y z -> bin_lt x z.
Proof.
 intros x y z; unfold bin_lt in |- *.
 apply lt_trans.
Defined.

Lemma bin_lt_is_order : is_order Qpositive bin_lt.
Proof.
 split.
 apply bin_lt_is_irreflexive.
 apply bin_lt_is_transitive.
Defined.

Lemma bin_eq_is_reflexive : forall x : Qpositive, bin_eq x x.
Proof.
 intros.
 unfold bin_eq in |- *.
 reflexivity.
Defined.

Lemma bin_eq_is_symmetric : forall x y : Qpositive, bin_eq x y -> bin_eq y x.
Proof.
 intros x y.
 unfold bin_eq in |- *.
 apply sym_eq.
Defined.

Lemma bin_eq_is_transitive :
 forall x y z : Qpositive, bin_eq x y -> bin_eq y z -> bin_eq x z.
Proof.
 intros x y z.
 unfold bin_eq in |- *.
 apply trans_eq.
Defined.

Lemma bin_eq_is_equality : is_equality Qpositive bin_eq.
Proof.
 split.
 apply bin_eq_is_reflexive.
 split.
 apply bin_eq_is_symmetric.
 apply bin_eq_is_transitive.
Defined.

Lemma bin_lt_is_wf : wf_ind Qpositive bin_lt.
Proof.
 generalize
  (well_founded_lt_compat Qpositive Qpositive_length bin_lt
     bin_lt_compat_via_length).
 intro H.
 exact (well_founded_ind H).
Defined.

Lemma bin_lt_is_well_def_rht : is_well_def_rht Qpositive bin_lt bin_eq.
Proof.
 red in |- *.
 intros.
 red in H0.
 rewrite <- H0.
 assumption.
Defined.

Definition Qpositive_as_well_ordering :=
  Build_well_ordering Qpositive bin_lt bin_eq bin_lt_is_order
    bin_eq_is_equality bin_lt_is_wf bin_lt_is_well_def_rht.

Lemma qlt_wf_rec_without_zeros_and_One :
 forall P : Z -> Z -> Z -> Z -> Qpositive -> Prop,
 (forall (a b c d : Z_pos) (p : Qpositive),
  (forall (r s t u : Z_pos) (p1 : Qpositive),
   qlt r s t u p1 a b c d p -> P r s t u p1) -> P a b c d p) ->
 forall (a b c d : Z_pos) (p : Qpositive), P a b c d p.
Proof.
 intros P H (a, Ha) (b, Hb) (c, Hc) (d, Hd) p.
 set
  (P2 :=
   fun (p_i : Qpositive) (x : Z4) =>
   P (fst (fst x)) (snd (fst x)) (fst (snd x)) (snd (snd x)) p_i)
  in *.
 simpl in |- *.

 assert (z4prf_Z4 : (0 <= a)%Z /\ (0 <= b)%Z /\ (0 <= c)%Z /\ (0 <= d)%Z);
  repeat split; try assumption.

 assert (P2 p (Build_Z4 (a, b, (c, d)) z4prf_Z4)).

 apply (merge_lt_wf Qpositive_as_well_ordering Z4_as_well_ordering).
 intro p_i.
 intros (((a_i, b_i), (c_i, d_i)), q); revert q.
 unfold P2 in |- *.
 simpl in |- *.
 intros (Ha_i, (Hb_i, (Hc_i, Hd_i))).
 intros.
 change
   (P (Build_Z_pos a_i Ha_i) (Build_Z_pos b_i Hb_i)
      (Build_Z_pos c_i Hc_i) (Build_Z_pos d_i Hd_i) p_i)
  in |- *.
 apply H.
 intros (r_, r_p) (s_, s_p) (t_, t_p) (u_, u_p) p1.
 simpl in |- *.
 intro H1.
 assert
  (z4prf2_Z4 : (0 <= r_)%Z /\ (0 <= s_)%Z /\ (0 <= t_)%Z /\ (0 <= u_)%Z);
  repeat split; try assumption.
 apply (H0 p1 (Build_Z4 (r_, s_, (t_, u_)) z4prf2_Z4)).
 case H1.
 intro.
 left.
 assumption.
 intros (H2, H3).
 right.
 split; assumption.
 assumption.
Defined.

Lemma homographicAcc_wf :
 forall (a b c d : Z) (p : Qpositive),
 (0 < a + b)%Z ->
 (0 < c + d)%Z ->
 (0 <= a)%Z ->
 (0 <= b)%Z -> (0 <= c)%Z -> (0 <= d)%Z -> homographicAcc a b c d p.
Proof.
 intros a b c d p Hab Hcd Ha Hb Hc Hd.
 set (ha := Build_Z_pos a Ha) in *.
 set (hb := Build_Z_pos b Hb) in *.
 set (hc := Build_Z_pos c Hc) in *.
 set (hd := Build_Z_pos d Hd) in *.
 generalize Hab Hcd Ha Hb Hc Hd.
 change
   ((0 < ha + hb)%Z ->
    (0 < hc + hd)%Z ->
    (0 <= ha)%Z ->
    (0 <= hb)%Z -> (0 <= hc)%Z -> (0 <= hd)%Z -> homographicAcc ha hb hc hd p)
  in |- *.

 apply
  qlt_wf_rec_without_zeros_and_One
   with
     (P := fun (r s t u : Z) (p1 : Qpositive) =>
           (0 < r + s)%Z ->
           (0 < t + u)%Z ->
           (0 <= r)%Z ->
           (0 <= s)%Z ->
           (0 <= t)%Z -> (0 <= u)%Z -> homographicAcc r s t u p1).

 intros a0 b0 c0 d0 p0 hyp1_aux.

(* modifying hyp1_aux *)
 assert
  (hyp1 :
   forall (r s t u : Z) (p1 : Qpositive),
   qlt r s t u p1 a0 b0 c0 d0 p0 ->
   (0 < r + s)%Z ->
   (0 < t + u)%Z ->
   (0 <= r)%Z ->
   (0 <= s)%Z -> (0 <= t)%Z -> (0 <= u)%Z -> homographicAcc r s t u p1).
 intros.
 change
   (homographicAcc (Build_Z_pos r H2) (Build_Z_pos s H3)
      (Build_Z_pos t H4) (Build_Z_pos u H5) p1) in |- *.
 apply hyp1_aux; repeat assumption.
(* end modifying hyp1 *)

 destruct p0 as [q| q| ].

 (** p0 = (nR p0) *)
  case (top_more_informative a0 b0 c0 d0).
  (** (top_more a0 b0 c0 d0) *)
   intros.
   apply homographicacc1.
   discriminate.
   assumption.
   apply hyp1.
   right.
   split.
   reflexivity.
   apply top_more_5.
   assumption.
   apply top_more_1.
   assumption.
   assumption.
   apply Zle_minus.
   apply (top_more_4 _ _ _ _ t).
   apply Zle_minus.
   apply (top_more_4' _ _ _ _ t).
   assumption.
   assumption.
  (** ~(top_more a0 b0 c0 d0) *)
   intro.
   case (top_more_informative c0 d0 a0 b0).
   (** (top_more c0 d0 a0 b0) *)
    intros.
    apply homographicacc2.
    discriminate.
    assumption.
    assumption.
    apply hyp1.
    right.
    split.
    reflexivity.
    apply top_more_5'.
    assumption.
    assumption.
    apply top_more_1.
    assumption.
    assumption.
    assumption.
    apply Zle_minus.
    apply (top_more_4 _ _ _ _ t).
    apply Zle_minus.
    apply (top_more_4' _ _ _ _ t).
   (** ~(top_more c0 d0 a0 b0) *)
    intros.
    apply homographicacc3.
    (* Discriminate. *)(**)
    assumption.
    assumption.
    apply hyp1.

    left.
    unfold bin_lt in |- *.
    apply compare_nR.

    replace 0%Z with (0 + 0)%Z.
    apply Zplus_le_lt_compat.
    assumption.
    assumption.
    constructor.
    replace 0%Z with (0 + 0)%Z.
    apply Zplus_le_lt_compat.
    assumption.
    assumption.
    constructor.
    assumption.
    apply Zlt_le_weak.
    assumption.
    assumption.
    apply Zlt_le_weak.
    assumption.
 (** p0 = (dL p0) *)
  case (top_more_informative a0 b0 c0 d0).
  (** (top_more a0 b0 c0 d0) *)
   intros.
   apply homographicacc1.
   discriminate.
   assumption.
   apply hyp1.
   right.

   split.
   reflexivity.

   apply top_more_5.
   assumption.

   apply top_more_1.
   assumption.
   assumption.
   apply Zle_minus.
   apply (top_more_4 _ _ _ _ t).
   apply Zle_minus.
   apply (top_more_4' _ _ _ _ t).
   assumption.
   assumption.
  (** ~(top_more a0 b0 c0 d0) *)
   intro.
   case (top_more_informative c0 d0 a0 b0).
   (** (top_more c0 d0 a0 b0) *)
    intros.
    apply homographicacc2.
    discriminate.
    assumption.
    assumption.
    apply hyp1.
    right.

    split.
    reflexivity.

    apply top_more_5'.
    assumption.

    assumption.
    apply top_more_1.
    assumption.
    assumption.
    assumption.
    apply Zle_minus.
    apply (top_more_4 _ _ _ _ t).
    apply Zle_minus.
    apply (top_more_4' _ _ _ _ t).
   (** ~(top_more c0 d0 a0 b0) *)
    intros.
    apply homographicacc3'.

    assumption.
    assumption.
    apply hyp1.
    left.

    unfold bin_lt in |- *.
    apply compare_dL.
    replace 0%Z with (0 + 0)%Z.
    apply Zplus_lt_le_compat.
    assumption.
    assumption.
    constructor.
    replace 0%Z with (0 + 0)%Z.
    apply Zplus_lt_le_compat.
    assumption.
    assumption.
    constructor.
    apply Zlt_le_weak.
    assumption.
    assumption.
    apply Zlt_le_weak.
    assumption.
    assumption.
 (** p = One *)
  intros.
  apply homographicacc0.
  reflexivity.
  assumption.
  assumption.
Defined.

(* TEST part *)
(* This part is an attempt to test the computational power of "Qhomographic_Qpositive_to_Qpositive" function. We try to calculate h(x)=2x+3/(x+4) for x:=1 *)
(* TEST 1 : 01_08_02 RAM:386MB Coq:7.3 OS:Redhat7.3   RESULT:insufficient memory *)

Remark one_non_negative : (0 <= 1)%Z.
Proof.
 apply Zorder.Zle_0_pos.
Defined.

Remark two_non_negative : (0 <= 2)%Z.
Proof.
 apply Zorder.Zle_0_pos.
Defined.

Remark three_non_negative : (0 <= 3)%Z.
Proof.
 apply Zorder.Zle_0_pos.
Defined.

Remark four_non_negative : (0 <= 4)%Z.
Proof.
 apply Zorder.Zle_0_pos.
Defined.

Remark five_non_negative : (0 <= 5)%Z.
Proof.
 apply Zorder.Zle_0_pos.
Defined.

Remark six_non_negative : (0 <= 6)%Z.
Proof.
 apply Zorder.Zle_0_pos.
Defined.

Remark seven_non_negative : (0 <= 7)%Z.
Proof.
 apply Zorder.Zle_0_pos.
Defined.

Remark two_plus_three_positive : (0 < 2 + 3)%Z.
Proof.
 simpl in |- *.
 apply ZERO_lt_POS.
Defined.

Remark one_plus_four_positive : (0 < 1 + 4)%Z.
Proof.
 simpl in |- *.
 apply ZERO_lt_POS.
Defined.

Definition homographicacc_wf_for_five_over_five :=
  homographicAcc_wf 2 3 1 4 One two_plus_three_positive
    one_plus_four_positive two_non_negative three_non_negative
    one_non_negative four_non_negative.

(* TEST: Eval Compute in (Qhomographic_Qpositive_to_Qpositive `2` `3` `1` `4` (One) homographicacc_wf_for_five_over_five). *)

(* End of the TEST part *)

(** Proof independence of Qhomographic_Qpositive_to_Qpositive: *)

Scheme homographicAcc_ind_dep := Induction for homographicAcc Sort Prop.

Lemma Qhomographic_Qpositive_to_Qpositive_equal :
 forall (a b c d : Z) (p : Qpositive) (hyp1 hyp2 : homographicAcc a b c d p),
 Qhomographic_Qpositive_to_Qpositive a b c d p hyp1 =
 Qhomographic_Qpositive_to_Qpositive a b c d p hyp2.
Proof.
 intros a b c d p hyp1 hyp2.
 generalize hyp2.
 clear hyp2.
 pattern a, b, c, d, p, hyp1 in |- *.
 elim hyp1 using homographicAcc_ind_dep; clear a b c d p hyp1.

 (* 1st big subgoal *)
   intros a b c d p Hp Hab Hcd hyp2; generalize Hp Hab Hcd; clear Hp Hab Hcd.
   pattern a, b, c, d, p, hyp2 in |- *.
   elim hyp2 using homographicAcc_ind_dep; clear a b c d p hyp2; intros.

    (* 1.1 *)
    simpl in |- *.
    case (Qpositive_dec_One p); intro Hp_; [ idtac | Falsum ].
    apply positive_fraction_encoding_equal.
    (* 1.2 *)
    Falsum.
    (* 1.3 *)
    Falsum.
    (* 1.4 *)
    discriminate Hp.
    (* 1.5 *)
    discriminate Hp.

 (* 2nd big subgoal *)
   intros a b c d p Hp Habcd hyp1 H_ind hyp2; generalize Hp Habcd hyp1 H_ind;
    clear Hp Habcd H_ind hyp1.
   pattern a, b, c, d, p, hyp2 in |- *.
   elim hyp2 using homographicAcc_ind_dep; clear a b c d p hyp2; intros.

    (* 2.1 *)
    Falsum.
    (* 2.2 *)
    simpl in |- *; case (Qpositive_dec_One p); intro Hp_; [ Falsum | idtac ];
     case (top_more_informative a b c d); intro Habcd_;
     [ idtac | Falsum ]; apply f_equal with Qpositive;
     apply H_ind.
    (* 2.3 *)
    Falsum.
    (* 2.4 *)
    Falsum.
    (* 2.5 *)
    Falsum.

 (* 3rd big subgoal *)
   intros a b c d p Hp Habcd Hcdab hyp1 H_ind hyp2;
    generalize Hp Habcd Hcdab hyp1 H_ind; clear Hp Habcd Hcdab H_ind hyp1.
   pattern a, b, c, d, p, hyp2 in |- *.
   elim hyp2 using homographicAcc_ind_dep; clear a b c d p hyp2; intros.

    (* 3.1 *)
    Falsum.
    (* 3.2 *)
    Falsum.
    (* 3.3 *)
    simpl in |- *; case (Qpositive_dec_One p); intro Hp_; [ Falsum | idtac ];
     case (top_more_informative a b c d); intro Habcd_;
     [ Falsum | idtac ]; case (top_more_informative c d a b);
     intro Hcdab_; [ idtac | Falsum ]; apply f_equal with Qpositive;
     apply H_ind.
    (* 3.4 *)
    Falsum.
    (* 3.5 *)
    Falsum.

 (* 4th big subgoal *)
   intros a b c d xs Habcd Hcdab hyp1 H_ind hyp2.
   set (P := nR xs) in *; assert (HP : P = nR xs); trivial; generalize HP.
   generalize Habcd Hcdab hyp1 H_ind.
   clear Habcd Hcdab H_ind hyp1.
   (* here we copy-paste the current goal but change the 2nd occurnece of P to (dL xs) *)
   elim hyp2 using
    homographicAcc_ind_dep
     with
       (P := fun (a b c d : Z) (P : Qpositive)
               (hyp2 : homographicAcc a b c d P) =>
             forall (Habcd : ~ top_more a b c d) (Hcdab : ~ top_more c d a b)
               (hyp1 : homographicAcc a (a + b) c (c + d) xs),
             (forall hyp2 : homographicAcc a (a + b) c (c + d) xs,
              Qhomographic_Qpositive_to_Qpositive a (a + b) c (c + d) xs hyp1 =
              Qhomographic_Qpositive_to_Qpositive a (a + b) c (c + d) xs hyp2) ->
             P = nR xs ->
             Qhomographic_Qpositive_to_Qpositive a b c d
               (nR xs) (homographicacc3 a b c d xs Habcd Hcdab hyp1) =
             Qhomographic_Qpositive_to_Qpositive a b c d P hyp2);
    clear a b c d hyp2; intros.

    (* 4.1 *)
    Falsum; rewrite H0 in e; discriminate e.
    (* 4.2 *)
    Falsum.
    (* 4.3 *)
    Falsum.
    (* 4.4 *)
    simpl in |- *.
    case (top_more_informative a b c d); intro Habcd_; [ Falsum | idtac ];
     case (top_more_informative c d a b); intro Hcdab_;
     [ Falsum | idtac ].
    generalize h;
     let T_local := eval compute in (f_equal Qpositive_tail H1) in
     rewrite T_local.
    intro; apply H0.
    (* 4.5 *)
    discriminate H1.

 (* 5th big subgoal *)
   intros a b c d xs Habcd Hcdab hyp1 H_ind hyp2.
   set (P := dL xs) in *; assert (HP : P = dL xs); trivial; generalize HP.
   generalize Habcd Hcdab hyp1 H_ind.
   clear Habcd Hcdab H_ind hyp1.
   elim hyp2 using
    homographicAcc_ind_dep
     with
       (P := fun (a b c d : Z) (P : Qpositive)
               (hyp2 : homographicAcc a b c d P) =>
             forall (Habcd : ~ top_more a b c d) (Hcdab : ~ top_more c d a b)
               (hyp1 : homographicAcc (a + b) b (c + d) d xs),
             (forall hyp2 : homographicAcc (a + b) b (c + d) d xs,
              Qhomographic_Qpositive_to_Qpositive (a + b) b (c + d) d xs hyp1 =
              Qhomographic_Qpositive_to_Qpositive (a + b) b (c + d) d xs hyp2) ->
             P = dL xs ->
             Qhomographic_Qpositive_to_Qpositive a b c d
               (dL xs) (homographicacc3' a b c d xs Habcd Hcdab hyp1) =
             Qhomographic_Qpositive_to_Qpositive a b c d P hyp2);
    clear a b c d hyp2; intros.

    (* 5.1 *)
    Falsum; rewrite H0 in e; discriminate e.
    (* 5.2 *)
    Falsum.
    (* 5.3 *)
    Falsum.
    (* 5.4 *)
    discriminate H1.
    (* 5.5 *)
    simpl in |- *.
    case (top_more_informative a b c d); intro Habcd_; [ Falsum | idtac ];
     case (top_more_informative c d a b); intro Hcdab_;
     [ Falsum | idtac ].
    generalize h;
     let T_local := eval compute in (f_equal Qpositive_tail H1) in
     rewrite T_local.
    intro; apply H0.
Defined.

Lemma Qhomographic_Qpositive_to_Qpositive_equal_strong :
 forall (a1 a2 b1 b2 c1 c2 d1 d2 : Z) (p1 p2 : Qpositive)
   (hyp1 : homographicAcc a1 b1 c1 d1 p1)
   (hyp2 : homographicAcc a2 b2 c2 d2 p2),
 a1 = a2 ->
 b1 = b2 ->
 c1 = c2 ->
 d1 = d2 ->
 p1 = p2 ->
 Qhomographic_Qpositive_to_Qpositive a1 b1 c1 d1 p1 hyp1 =
 Qhomographic_Qpositive_to_Qpositive a2 b2 c2 d2 p2 hyp2.
Proof.
 intros.
 subst.
 apply Qhomographic_Qpositive_to_Qpositive_equal.
Defined.

(** Here we expand the fixpoint equations of "Qhomographic_Qpositive_to_Qpositive" function *)

Lemma Qhomographic_Qpositive_to_Qpositive_0 :
 forall (a b c d : Z) (p : Qpositive) (hyp : homographicAcc a b c d p),
 p = One ->
 forall (H1 : (0 < a + b)%Z) (H2 : (0 < c + d)%Z),
 Qhomographic_Qpositive_to_Qpositive a b c d p hyp =
 positive_fraction_encoding (a + b) (c + d) H1 H2.
Proof.
 intros.
 apply
  trans_eq
   with
     (Qhomographic_Qpositive_to_Qpositive a b c d One
        (homographicacc0 a b c d One (refl_equal One) H1 H2)).
 apply Qhomographic_Qpositive_to_Qpositive_equal_strong; repeat reflexivity.
 assumption.
  simpl in |- *.
  apply positive_fraction_encoding_equal.
Defined.

Lemma Qhomographic_Qpositive_to_Qpositive_1 :
 forall (a b c d : Z) (p : Qpositive) (hyp : homographicAcc a b c d p),
 p <> One ->
 top_more a b c d ->
 forall h : homographicAcc (a - c) (b - d) c d p,
 Qhomographic_Qpositive_to_Qpositive a b c d p hyp =
 nR (Qhomographic_Qpositive_to_Qpositive (a - c) (b - d) c d p h).
Proof.
 intros.
 apply
  trans_eq
   with
     (Qhomographic_Qpositive_to_Qpositive a b c d p
        (homographicacc1 a b c d p H H0 h)).
 apply Qhomographic_Qpositive_to_Qpositive_equal.
  simpl in |- *.
  case (Qpositive_dec_One p); intros Hp; [ Falsum | idtac ].
  case (top_more_informative a b c d); intros Habcd; [ idtac | Falsum ].
  apply f_equal with Qpositive; reflexivity.
Defined.

Lemma Qhomographic_Qpositive_to_Qpositive_2 :
 forall (a b c d : Z) (p : Qpositive) (hyp : homographicAcc a b c d p),
 p <> One ->
 ~ top_more a b c d ->
 top_more c d a b ->
 forall h : homographicAcc a b (c - a) (d - b) p,
 Qhomographic_Qpositive_to_Qpositive a b c d p hyp =
 dL (Qhomographic_Qpositive_to_Qpositive a b (c - a) (d - b) p h).
Proof.
 intros.
 apply
  trans_eq
   with
     (Qhomographic_Qpositive_to_Qpositive a b c d p
        (homographicacc2 a b c d p H H0 H1 h)).
 apply Qhomographic_Qpositive_to_Qpositive_equal.
  simpl in |- *.
  case (Qpositive_dec_One p); intros Hp; [ Falsum | idtac ].
  case (top_more_informative a b c d); intros Habcd; [ Falsum | idtac ].
  case (top_more_informative c d a b); intros Hcdab; [ idtac | Falsum ].
  apply f_equal with Qpositive; reflexivity.
Defined.

Lemma Qhomographic_Qpositive_to_Qpositive_3 :
 forall (a b c d : Z) (p : Qpositive) (hyp : homographicAcc a b c d p),
 ~ top_more a b c d ->
 ~ top_more c d a b ->
 forall xs : Qpositive,
 p = nR xs ->
 forall h : homographicAcc a (a + b) c (c + d) xs,
 Qhomographic_Qpositive_to_Qpositive a b c d p hyp =
 Qhomographic_Qpositive_to_Qpositive a (a + b) c (c + d) xs h.
Proof.
 intros.
 apply
  trans_eq
   with
     (Qhomographic_Qpositive_to_Qpositive a b c d (nR xs)
        (homographicacc3 a b c d xs H H0 h)).
 apply Qhomographic_Qpositive_to_Qpositive_equal_strong; trivial.
  simpl in |- *.
  case (top_more_informative a b c d); intros Habcd; [ Falsum | idtac ].
  case (top_more_informative c d a b); intros Hcdab; [ Falsum | idtac ].
  reflexivity.
Defined.

Lemma Qhomographic_Qpositive_to_Qpositive_3' :
 forall (a b c d : Z) (p : Qpositive) (hyp : homographicAcc a b c d p),
 ~ top_more a b c d ->
 ~ top_more c d a b ->
 forall xs : Qpositive,
 p = dL xs ->
 forall h : homographicAcc (a + b) b (c + d) d xs,
 Qhomographic_Qpositive_to_Qpositive a b c d p hyp =
 Qhomographic_Qpositive_to_Qpositive (a + b) b (c + d) d xs h.
Proof.
 intros.
 apply
  trans_eq
   with
     (Qhomographic_Qpositive_to_Qpositive a b c d (dL xs)
        (homographicacc3' a b c d xs H H0 h)).
 apply Qhomographic_Qpositive_to_Qpositive_equal_strong; trivial.
  simpl in |- *.
  case (top_more_informative a b c d); intros Habcd; [ Falsum | idtac ].
  case (top_more_informative c d a b); intros Hcdab; [ Falsum | idtac ].
  reflexivity.
Defined.


(**
_AUTHOR_

<<
Zhi Zhang
Department of Computer and Information Sciences
Kansas State University
zhangzhi@ksu.edu
>>
*)

Require Export FunInd rt_gen_impl.

(* ***************************************************************
                 Semantics Equivalence Proof
   *************************************************************** *)

(** * Semantics Consistency Proof for Run-Time Check Generator *)

Scheme expression_ind := Induction for exp Sort Prop
                         with name_ind := Induction for name Sort Prop.

(** * Soundness of RT-GEN Implementation *)

Section Checks_Generator_Implementation_Soundness_Proof.

  (** ** toExpRTImpl_soundness *)
  Lemma toExpRTImpl_soundness: forall e e' st,
    toExpRTImpl st e = e' ->
      toExpRT st e e'.
  Proof.
    apply (expression_ind
      (fun e: exp => forall (e' : expRT) (st: symTab),
        toExpRTImpl st e = e' ->
        toExpRT   st e e')
      (fun n: name => forall (n': nameRT) (st: symTab),
        toNameRTImpl st n = n' ->
        toNameRT   st n n')
      ); smack;
    [ (*Literal*)
      destruct l;
      [ remember ((min_signed <=? z)%Z && (z <=? max_signed)%Z) as b; destruct b;
        smack; constructor; smack |
        smack; constructor
      ] |
      (*Name*) |
      (*BinOp a b e e0*) destruct b |
      (*UnOp a u e*) destruct u |
      (*Identifier a i*) |
      (*IndexedComponent a n e*) |
      (*SelectedComponent a n i*)
    ];
    match goal with
    | [H: _ = ?b |- in_bound _ _ ?b] => rewrite <- H; constructor; smack
    | _ => constructor; smack
    end.
  Qed.

  (** ** toNameRTImpl_soundness *)
  Lemma toNameRTImpl_soundness: forall st n n',
    toNameRTImpl st n = n' ->
      toNameRT st n n'.
  Proof.
    intros st n;
    induction n; smack; constructor; smack;
    apply toExpRTImpl_soundness; auto.
  Qed.

  (** ** toArgsRTImpl_soundness *)
  Lemma toArgsRTImpl_soundness: forall st params args args',
    toArgsRTImpl st params args = Some args' ->
      toArgsRT st params args args'.
  Proof.
    induction params; smack.
  - destruct args; smack;
    constructor.
  - destruct args; smack.
    remember (toArgsRTImpl st params args) as b1;
    remember (parameter_mode a) as b2;
    destruct b1, b2; smack.
    + (*In Mode*)
      remember (is_range_constrainted_type (parameter_subtype_mark a)) as x;
      destruct x; smack;
      [ apply ToArgsInRangeCheck |
        apply ToArgsIn
      ]; smack;
      apply toExpRTImpl_soundness; auto.
    + (*Out Mode*)
      destruct e; smack;
      remember (fetch_exp_type a0 st) as b3;
      destruct b3; smack;
      remember (is_range_constrainted_type t) as b4; destruct b4; smack;
      [ apply ToArgsOutRangeCheck with (t := t) |
        apply ToArgsOut with (t := t)
      ]; smack;
      apply toNameRTImpl_soundness; auto.
    + (*In_Out Mode*)
      destruct e; smack;
      remember (is_range_constrainted_type (parameter_subtype_mark a)) as b3;
      remember (fetch_exp_type a0 st) as b4;
      destruct b3, b4; smack;
      remember (is_range_constrainted_type t) as b5;
      destruct b5; smack;
      [ apply ToArgsInOutRangeCheck with (t:=t) |
        apply ToArgsInOutRangeCheckIn with (t:=t) |
        apply ToArgsInOutRangeCheckOut with (t:=t) |
        apply ToArgsInOut with (t:=t)
      ]; auto;
      apply toNameRTImpl_soundness; auto.
  Qed.

  (** ** toStmtRTImpl_soundness *)
  Lemma toStmtRTImpl_soundness: forall st c c',
    toStmtRTImpl st c = Some c' ->
      toStmtRT st c c'.
  Proof.
    induction c; smack.
  - (*Null*)
    constructor.
  - (*Assign*)
    remember (fetch_exp_type (name_astnum n) st ) as b1;
    destruct b1; smack;
    remember (is_range_constrainted_type t) as b2;
    destruct b2; smack;
    [ apply ToAssignRangeCheck with (t := t) |
      apply ToAssign with (t := t)
    ]; auto;
    solve
    [ apply toNameRTImpl_soundness; auto |
      apply toExpRTImpl_soundness; auto
    ].
  - (*If*)
    remember (toStmtRTImpl st c1) as b1;
    remember (toStmtRTImpl st c2) as b2;
    destruct b1, b2; smack;
    constructor; smack;
    apply toExpRTImpl_soundness; auto.
  - (*While*)
    remember (toStmtRTImpl st c) as b1;
    destruct b1; smack;
    constructor; smack;
    apply toExpRTImpl_soundness; auto.
  - (*Call*)
    remember (fetch_proc p st) as b1;
    destruct b1; smack;
    destruct t;
    remember (toArgsRTImpl st (procedure_parameter_profile p0) l) as b2;
    destruct b2; smack;
    apply ToCall with (n0 := l0) (pb := p0) (params := (procedure_parameter_profile p0)); smack;
    apply toArgsRTImpl_soundness; auto.
  - (*Seq*)
    remember (toStmtRTImpl st c1) as b1;
    remember (toStmtRTImpl st c2) as b2;
    destruct b1, b2; smack;
    constructor; auto.
  Qed.

  Lemma toTypeDeclRTImpl_soundness: forall t t',
    toTypeDeclRTImpl t = t' ->
        toTypeDeclRT t t'.
  Proof.
    destruct t; smack;
    try (destruct r); constructor.
  Qed.

  Lemma toObjDeclRTImpl_soundness: forall st o o',
    toObjDeclRTImpl st o = o' ->
      toObjDeclRT st o o'.
  Proof.
    intros;
    functional induction toObjDeclRTImpl st o; smack;
    [ constructor |
      apply ToObjDeclRangeCheck |
      apply ToObjDecl
    ]; auto; apply toExpRTImpl_soundness; auto.
  Qed.

  Lemma toObjDeclsRTImpl_soundness: forall st lo lo',
    toObjDeclsRTImpl st lo = lo' ->
      toObjDeclsRT st lo lo'.
  Proof.
    induction lo; smack;
    constructor; smack;
    apply toObjDeclRTImpl_soundness; auto.
  Qed.

  Lemma toParamSpecRTImpl_soundness: forall param param',
    toParamSpecRTImpl param = param' ->
      toParamSpecRT param param'.
  Proof.
    smack;
    destruct param;
    constructor.
  Qed.

  Lemma toParamSpecsRTImpl_soundness: forall lparam lparam',
    toParamSpecsRTImpl lparam = lparam' ->
      toParamSpecsRT lparam lparam'.
  Proof.
    induction lparam; smack;
    constructor; smack;
    apply toParamSpecRTImpl_soundness; auto.
  Qed.

  Scheme declaration_ind := Induction for decl Sort Prop
                            with procedure_body_ind := Induction for procBodyDecl Sort Prop.

  (** ** toDeclRTImpl_soundness *)

  Lemma toDeclRTImpl_soundness: forall d d' st,
    toDeclRTImpl st d = Some d' ->
      toDeclRT st d d'.
  Proof.
    apply (declaration_ind
      (fun d: decl => forall (d' : declRT) (st: symTab),
        toDeclRTImpl st d = Some d' ->
        toDeclRT st d d')
      (fun p: procBodyDecl => forall (p': procBodyDeclRT) (st: symTab),
        toProcBodyDeclRTImpl st p = Some p' ->
        toProcBodyDeclRT st p p')
      ); smack.
  - constructor.
  - constructor;
    apply toTypeDeclRTImpl_soundness; auto.
  - constructor;
    apply toObjDeclRTImpl_soundness; auto.
  - remember (toProcBodyDeclRTImpl st p) as x;
    destruct x; smack;
    constructor; auto.
  - remember (toDeclRTImpl st d) as x;
    remember (toDeclRTImpl st d0) as y;
    destruct x, y; smack;
    constructor; smack.
  - remember (toDeclRTImpl st procedure_declarative_part) as x;
    remember (toStmtRTImpl st procedure_statements) as y;
    destruct x, y; smack;
    constructor;
    [ apply toParamSpecsRTImpl_soundness | |
      apply toStmtRTImpl_soundness
    ]; auto.
  Qed.

  (** ** toProcBodyDeclRTImpl_soundness *)

  Lemma toProcBodyDeclRTImpl_soundness: forall st p p',
    toProcBodyDeclRTImpl st p = Some p' ->
      toProcBodyDeclRT st p p'.
  Proof.
    intros;
    destruct p; smack.
    remember (toDeclRTImpl st procedure_declarative_part) as x;
    remember (toStmtRTImpl st procedure_statements) as y;
    destruct x, y; smack;
    constructor;
    [ apply toParamSpecsRTImpl_soundness |
      apply toDeclRTImpl_soundness |
      apply toStmtRTImpl_soundness
    ]; auto.
  Qed.

  (** ** toProgramRTImpl_soundness *)

  Lemma toProgramRTImpl_soundness: forall st p p',
    toProgramRTImpl st p = Some p' ->
      toProgramRT st p p'.
  Proof.
    intros.
    destruct p, p'.
    unfold toProgramRTImpl in H;
    inversion H; subst; clear H.
    remember (toDeclRTImpl st decls) as x.
    destruct x; inversion H1; subst.
    constructor;
    apply toDeclRTImpl_soundness; auto.
  Qed.

End Checks_Generator_Implementation_Soundness_Proof.

(** * Completeness of RT-GEN Implementation *)

Section Checks_Generator_Implementation_Completeness_Proof.

  (** ** toExpRTImpl_completeness *)

  Lemma toExpRTImpl_completeness: forall e e' st,
    toExpRT st e e' ->
      toExpRTImpl st e = e'.
  Proof.
    apply (expression_ind
      (fun e: exp => forall (e' : expRT) (st: symTab),
        toExpRT   st e e' ->
        toExpRTImpl st e = e')
      (fun n: name => forall (n': nameRT) (st: symTab),
        toNameRT   st n n' ->
        toNameRTImpl st n = n')
      ); smack;
    match goal with
    | [H: toExpRT  _ ?e ?e' |- _] => inversion H; clear H; smack
    | [H: toNameRT _ ?n ?n' |- _] => inversion H; clear H; smack
    end;
    repeat progress match goal with
    | [H1:forall (e' : expRT) (st : symTab),
          toExpRT _ ?e e' ->
          toExpRTImpl _ ?e = e',
       H2:toExpRT _ ?e ?e1RT |- _] => specialize (H1 _ _ H2); smack
    | [H1:forall (n' : nameRT) (st : symTab),
          toNameRT _ ?n n' ->
          toNameRTImpl _ ?n = n',
       H2:toNameRT _ ?n ?nRT |- _] => specialize (H1 _ _ H2); smack
    end;
    match goal with
    | [H: in_bound _ _ _ |- _] => inversion H; smack
    | _ => idtac
    end;
    [ destruct b |
      destruct u
    ]; smack.
  Qed.

  (** ** toNameRTImpl_completeness *)
  Lemma toNameRTImpl_completeness: forall st n n',
    toNameRT st n n' ->
      toNameRTImpl st n = n'.
  Proof.
    intros;
    induction H; smack;
    match goal with
    | [H: toExpRT ?st ?e ?e' |- _] =>
        specialize (toExpRTImpl_completeness _ _ _ H); smack
    end; auto.
  Qed.

  (** ** toArgsRTImpl_completeness *)

  Lemma toArgsRTImpl_completeness: forall st params args args',
    toArgsRT st params args args' ->
      toArgsRTImpl st params args = Some args'.
  Proof.
    induction params; smack;
    match goal with
    | [H: toArgsRT _ _ ?args ?args' |- _] => inversion H; clear H; smack
    end;
    match goal with
    | [H1: forall (args : list exp) (args' : list expRT),
           toArgsRT _ ?params _ _ ->
           toArgsRTImpl _ ?params _ = Some _,
       H2: toArgsRT _ ?params _ _ |- _] => specialize (H1 _ _ H2)
    end;
    match goal with
    | [H: toArgsRTImpl ?st ?params ?larg = Some _ |- _] => rewrite H; simpl
    end;
    match goal with
    | [H: toExpRT _ ?e ?e' |- _] => specialize (toExpRTImpl_completeness _ _ _ H); smack
    | [H: toNameRT _ ?n ?n' |- _] => specialize (toNameRTImpl_completeness _ _ _ H); smack
    | _ => idtac
    end; auto.
  Qed.

  (** ** toStmtRTImpl_completeness *)

  Lemma toStmtRTImpl_completeness: forall st c c',
    toStmtRT st c c' ->
      toStmtRTImpl st c = Some c'.
  Proof.
    induction c; smack;
    match goal with
    | [H: toStmtRT _ ?c ?c' |- _] => inversion H; clear H; smack
    end;
    repeat progress match goal with
    | [H: toExpRT  _ ?e ?e' |- _] => specialize (toExpRTImpl_completeness  _ _ _ H); clear H
    | [H: toNameRT _ ?n ?n' |- _] => specialize (toNameRTImpl_completeness _ _ _ H); clear H
    | [H1: forall c' : stmtRT,
           toStmtRT _ ?c _ ->
           toStmtRTImpl _ ?c = Some _,
       H2: toStmtRT _ ?c _ |- _ ] => specialize (H1 _ H2)
    end; smack;
    match goal with
    | [H: toArgsRT _ _ _ _ |- _ ] => specialize (toArgsRTImpl_completeness _ _ _ _ H); smack
    end.
  Qed.

  Lemma toTypeDeclRTImpl_completeness: forall t t',
    toTypeDeclRT t t' ->
      toTypeDeclRTImpl t = t'.
  Proof.
    destruct t; intros;
    match goal with
    | [H: toTypeDeclRT _ _ |- _] => inversion H; smack
    end.
  Qed.

  Lemma toObjDeclRTImpl_completeness: forall st o o',
    toObjDeclRT st o o' ->
      toObjDeclRTImpl st o = o'.
  Proof.
    intros;
    functional induction toObjDeclRTImpl st o;
    match goal with
    | [H: toObjDeclRT _ _ _ |- _] => inversion H; smack
    end;
    match goal with
    | [H: toExpRT _ _ _ |- _] =>
        specialize (toExpRTImpl_completeness _ _ _ H); smack
    end.
  Qed.

  Lemma toObjDeclsRTImpl_completeness: forall st lo lo',
    toObjDeclsRT st lo lo' ->
      toObjDeclsRTImpl st lo = lo'.
  Proof.
    induction lo; smack;
    match goal with
    | [H: toObjDeclsRT _ _ _ |- _] => inversion H; clear H; smack
    end;
    match goal with
    | [H: toObjDeclRT _ ?o ?o' |- _] =>
        specialize (toObjDeclRTImpl_completeness _ _ _ H); smack
    end;
    specialize (IHlo _ H5); smack.
  Qed.

  Lemma toParamSpecRTImpl_completeness: forall param param',
    toParamSpecRT param param' ->
      toParamSpecRTImpl param = param'.
  Proof.
    intros;
    inversion H; auto.
  Qed.

  Lemma toParamSpecsRTImpl_completeness: forall lparam lparam',
    toParamSpecsRT lparam lparam' ->
      toParamSpecsRTImpl lparam = lparam'.
  Proof.
    induction lparam; intros;
    inversion H; auto;
    specialize (IHlparam _ H4);
    match goal with
    | [H: toParamSpecRT _ _ |- _] =>
        specialize (toParamSpecRTImpl_completeness _ _ H); smack
    end.
  Qed.

  (** ** toDeclRTImpl_completeness *)

  Lemma toDeclRTImpl_completeness: forall d d' st,
    toDeclRT st d d' ->
      toDeclRTImpl st d = Some d'.
  Proof.
    apply (declaration_ind
      (fun d: decl => forall (d' : declRT) (st: symTab),
        toDeclRT st d d' ->
        toDeclRTImpl st d = Some d')
      (fun p: procBodyDecl => forall (p': procBodyDeclRT) (st: symTab),
        toProcBodyDeclRT st p p' ->
        toProcBodyDeclRTImpl st p = Some p')
      ); smack;
    match goal with
    | [H: toDeclRT _ _ _ |- _] => inversion H; clear H; smack
    | [H: toProcBodyDeclRT _ _ _ |- _] => inversion H; clear H; smack
    end;
    repeat progress match goal with
    | [H: toTypeDeclRT _ _ |- _] =>
        specialize (toTypeDeclRTImpl_completeness _ _ H); smack
    | [H: toObjDeclRT _ _ _ |- _] =>
        specialize (toObjDeclRTImpl_completeness _ _ _ H); smack
    | [H: toParamSpecsRT _ _ |- _] =>
        specialize (toParamSpecsRTImpl_completeness _ _ H); clear H; smack
    | [H: toStmtRT _ _ _ |- _] =>
        specialize (toStmtRTImpl_completeness _ _ _ H); clear H; smack
    | [H1: forall (p' : procBodyDeclRT) (st : symTab),
           toProcBodyDeclRT _ ?p _ ->
           toProcBodyDeclRTImpl _ ?p = Some _,
       H2: toProcBodyDeclRT _ ?p _ |- _] =>
        specialize (H1 _ _ H2); smack
    | [H1: forall (d' : declRT) (st : symTab),
           toDeclRT _ ?d _ ->
           toDeclRTImpl _ ?d = Some _,
       H2: toDeclRT _ ?d _ |- _] =>
        specialize (H1 _ _ H2); clear H2; smack
    end.
  Qed.

  (** ** toProcBodyDeclRTImpl_completeness *)

  Lemma toProcBodyDeclRTImpl_completeness: forall st p p',
    toProcBodyDeclRT st p p' ->
      toProcBodyDeclRTImpl st p = Some p'.
  Proof.
    intros;
    destruct p;
    match goal with
    [H: toProcBodyDeclRT _ _ _ |- _] => inversion H; clear H; smack
    end;
    repeat progress match goal with
    | [H: toParamSpecsRT _ _ |- _] =>
        specialize (toParamSpecsRTImpl_completeness _ _ H); clear H; smack
    | [H: toStmtRT _ _ _ |- _] =>
        specialize (toStmtRTImpl_completeness _ _ _ H); clear H; smack
    | [H: toDeclRT _ _ _ |- _] =>
        specialize (toDeclRTImpl_completeness _ _ _ H); clear H; smack
    end.
  Qed.

  (** ** toProgramRTImpl_completeness *)

  Lemma toProgramRTImpl_completeness: forall st p p',
    toProgramRT st p p' ->
      toProgramRTImpl st p = Some p'.
  Proof.
    intros.
    destruct p, p'.
    inversion H; subst; clear H.
    simpl in H3.
    specialize (toDeclRTImpl_completeness _ _ _ H3); intro HZ.
    unfold toProgramRTImpl; simpl.
    rewrite HZ; auto.
  Qed.

End Checks_Generator_Implementation_Completeness_Proof.

(** * Consistency of RT-GEN Impl and RT-GEN Spec *)

(** ** toExpRTImplConsistent *)
Lemma toExpRTImplConsistent: forall e e' st,
  toExpRT st e e' <->
    toExpRTImpl st e = e'.
Proof.
  intros; split; intro;
  [ apply toExpRTImpl_completeness; auto |
    apply toExpRTImpl_soundness; auto
  ].
Qed.

(** ** toStmtRTImplConsistent *)
Lemma toStmtRTImplConsistent: forall st c c',
  toStmtRT st c c' <->
    toStmtRTImpl st c = Some c'.
Proof.
  intros; split; intro;
  [ apply toStmtRTImpl_completeness; auto |
    apply toStmtRTImpl_soundness; auto
  ].
Qed.

(** ** toProcBodyDeclRTConsistent *)
Lemma toProcBodyDeclRTConsistent: forall st p p',
  toProcBodyDeclRT st p p' <->
    toProcBodyDeclRTImpl st p = Some p'.
Proof.
  intros; split; intro;
  [ apply toProcBodyDeclRTImpl_completeness; auto |
    apply toProcBodyDeclRTImpl_soundness; auto
  ].
Qed.

(** ** toProgramRTImplConsistent *)
Lemma toProgramRTImplConsistent: forall st p p',
  toProgramRT st p p' <->
    toProgramRTImpl st p = Some p'.
Proof.
  intros; split; intro;
  [ apply toProgramRTImpl_completeness; auto |
    apply toProgramRTImpl_soundness; auto
  ].
Qed.


Require Import syntax.
Require Import alist.
Require Import FMapWeakList.

Require Import Classical.
Require Import Coqlib.
Require Import infrastructure.
Require Import Metatheory.
Import LLVMsyntax.
Import LLVMinfra.
Require Import opsem.
Require Import memory_props.

Require Import sflib.
Require Import paco.
Import Opsem.

Require Import TODO.
Require Import Exprs.
Require Import Postcond.
Require Import Hints.
Require Import Validator.
Require Import GenericValues.
Require AssnMem.
Require AssnState.
Require Import Inject.
Require Import SoundBase.
Require Import SoundSnapshot.
Require Import SoundForgetStack.
Require Import SoundReduceMaydiff.
Require Import SoundImplies.
Require Import TODOProof.
Require Import OpsemAux.
Require Import MemAux.

Set Implicit Arguments.

Lemma add_terminator_cond_br_uncond
      inv bid_src bid_tgt l:
  Postcond.add_terminator_cond
    inv
    (insn_br_uncond bid_src l)
    (insn_br_uncond bid_tgt l)
    l =
  inv.
Proof. destruct inv, src, tgt. ss. Qed.

Lemma add_terminator_cond_switch_unary
      conf val st gmax public
      ty gval cases l_dflt l_dest id
      invst assnmem inv
      (VAL : getOperandValue (CurTargetData conf) val
                             (Locals (EC st)) (Globals conf) = Some gval)
      (DECIDE : get_switch_branch (CurTargetData conf)
                                  ty gval cases l_dflt = Some l_dest)
      (STATE : AssnState.Unary.sem conf st invst assnmem gmax public inv)
  : AssnState.Unary.sem conf st invst assnmem gmax public
                       (Assertion.update_lessdef
                          (add_terminator_cond_lessdef
                             (insn_switch id ty val l_dflt cases) l_dest) inv).
Proof.
  inv STATE.
  econs; eauto. ss. ii.
  des_ifs; try by eapply LESSDEF; eauto.
  destruct p as [const_case l_case]. ss.
  rename Heq into FILTER_CASES.

  assert (CASE_AUX: In (const_case, l_case)
                       (List.filter (fun cl : const * l => l_dec l_dest (snd cl)) cases)).
  { rewrite FILTER_CASES. unfold In. eauto. }

  assert (CASE_IN: In (const_case, l_case) cases).
  { apply filter_In in CASE_AUX. des. eauto. }

  assert (CASE_UNIQUE: forall cl, In cl cases -> l_dec l_dest (snd cl) ->
                             cl = (const_case, l_case)).
  { i.
    cut (In cl [(const_case, l_case)]).
    { intro IN. inv IN; eauto. contradiction. }
    rewrite <- FILTER_CASES.
    apply filter_In. split; eauto.
  }
  (* gv_chunks_match_typ *)

  unfold get_switch_branch in DECIDE. des_ifs.
  unfold get_switch_branch_aux in *. des_ifs.
  exploit find_some; eauto. i. des. des_ifs. ss.
  exploit CASE_UNIQUE; eauto.
  { ss. destruct (l_dec l0 l0); ss. }
  i. clarify.
  specialize (Fcore_Zaux.Zeq_bool_spec z0 z).
  intro ZEQ. inv ZEQ; try congruence.
  destruct x as [e1 e2].

  do 2 rewrite ExprPairSetFacts.add_iff in *. des.
  - ss. clarify. ss.
    solve_leibniz. clarify. ss.
    rewrite AssnState.Unary.sem_valueT_physical in VAL1. clarify.

    unfold intConst2Z in *. des_ifs.

    esplits; eauto.
    + unfold const2GV. ss.
    + ss.
      unfold GV2int in *. des_ifs.
      unfold val2GV.
      econs; try by apply list_forall2_nil.
      split; ss.
      { rewrite <- H1.
        rewrite <- e.
        replace (n0+1-1)%nat with n0; try omega.
        rewrite Integers.Int.repr_signed. eauto.
      }
      { esplits; eauto.
        - rewrite <- e.
          replace (n0+1-1)%nat with n0; try omega.
          ss.
        - chunk_simpl.
      }
  - ss. clarify. ss.
    solve_leibniz. clarify. ss.
    rewrite AssnState.Unary.sem_valueT_physical. clarify.

    unfold intConst2Z in *. des_ifs.

    esplits; eauto.
    unfold const2GV in *. ss. clarify.
    unfold GV2int in *. des_ifs.
    econs; try by apply list_forall2_nil.
    ss. split.
    { rewrite <- H1.
      rewrite <- e.
      replace (n0+1-1)%nat with n0; try omega.
      rewrite Integers.Int.repr_signed. eauto.
    }
    { esplits; eauto.
      - rewrite <- e. replace (n0+1-1)%nat with n0; try omega. ss.
      - chunk_simpl.
    }
  - apply LESSDEF; eauto.
Qed.

Lemma add_terminator_cond_switch
      conf_src conf_tgt
      st_src st_tgt
      invst assnmem inv
      ty cases l_dflt l_dest
      id_src val_src gval_src
      id_tgt val_tgt gval_tgt
      (STATE: AssnState.Rel.sem
                conf_src conf_tgt st_src st_tgt
                invst assnmem inv)
      (VAL_SRC: getOperandValue
                  conf_src.(CurTargetData)
                  val_src
                  st_src.(EC).(Locals)
                  conf_src.(Globals) = Some gval_src)
      (VAL_TGT: getOperandValue
                  conf_tgt.(CurTargetData)
                  val_tgt
                  st_tgt.(EC).(Locals)
                  conf_tgt.(Globals) = Some gval_tgt)
      (DECIDE_SRC: get_switch_branch conf_src.(CurTargetData) ty gval_src cases l_dflt = Some l_dest)
      (DECIDE_TGT: get_switch_branch conf_tgt.(CurTargetData) ty gval_tgt cases l_dflt = Some l_dest)
  : AssnState.Rel.sem
      conf_src conf_tgt
      st_src st_tgt
      invst assnmem
      (Postcond.add_terminator_cond
         inv
         (insn_switch id_src ty val_src l_dflt cases)
         (insn_switch id_tgt ty val_tgt l_dflt cases) l_dest).
Proof.
  inv STATE.
  econs; eauto; ss.
  - eapply add_terminator_cond_switch_unary; eauto.
  - eapply add_terminator_cond_switch_unary; eauto.
Qed.

Lemma int_sizezero_cases_aux
      (i : Integers.Int.int 0)
  : (Integers.Int.eq 0 i (Integers.Int.zero 0) = true) \/
    (Integers.Int.eq 0 i (Integers.Int.one 0) = true).
Proof.
  destruct i. destruct intval.
  - left. ss.
  - unfold Integers.Int.modulus, two_power_nat in intrange. ss.
    destruct p.
    + specialize (Pos2Z.inj_xI p). i.
      specialize (Zgt_pos_0 p). i. omega.
    + specialize (Pos2Z.inj_xO p). i.
      specialize (Zgt_pos_0 p). i. omega.
    + right. ss.
  - specialize (Zlt_neg_0 p). i. omega.
Qed.

Lemma int_sizezero_cases
      (i : Integers.Int.int 0)
  : (i = (Integers.Int.zero 0)) \/
    (i = (Integers.Int.one 0)).
Proof.
  specialize (int_sizezero_cases_aux i). i. des.
  - left.
    exploit Integers.Int.eq_spec. i.
    rewrite H in *. eauto.
  - right.
    exploit Integers.Int.eq_spec. i.
    rewrite H in *. eauto.
Qed.

Lemma add_terminator_cond_br_unary
      conf val st gval decision
      invst assnmem inv gmax public
      id l1 l2
      (VAL : getOperandValue (CurTargetData conf) val
                             (Locals (EC st)) (Globals conf) = Some gval)
      (DECIDE : decide_nonzero (CurTargetData conf) gval decision)
      (STATE : AssnState.Unary.sem conf st invst assnmem gmax public inv)
  : AssnState.Unary.sem conf st invst assnmem gmax public
                       (Assertion.update_lessdef
                          (add_terminator_cond_lessdef (insn_br id val l1 l2)
                                                       (ite decision l1 l2))
                          inv).
Proof.
  inv STATE.
  econs; eauto.
  ii. unfold add_terminator_cond_lessdef in *. ss.
  destruct (l_dec l1 l2).
  { eapply LESSDEF; eauto. }
  inv DECIDE.

  destruct x as [e1 e2]. ss.

  do 2 rewrite ExprPairSetFacts.add_iff in *.
  des.
  - clarify. ss.
    solve_leibniz. clarify. ss.
    rewrite AssnState.Unary.sem_valueT_physical in VAL1.
    unfold ite in *.
    unfold GV2int in INT.
    unfold Size.to_nat, Size.One in *.
    des_ifs; ss.
    + rename n0 into wz.
      esplits; ss. ss.
      destruct wz; try omega.
      specialize (int_sizezero_cases i0). i.
      unfold val2GV. ss. econs; ss; cycle 1.
      { apply list_forall2_nil. }
      econs; eauto.
      { (* value *)
        des; subst; unfold Integers.Int.repr; ss. }
      { split; ss. }
    +  esplits; ss. ss.
       rename n1 into wz.
       destruct wz; try omega.
       specialize (int_sizezero_cases i0). i.
       unfold val2GV. ss. econs; ss; cycle 1.
       { apply list_forall2_nil. }
       econs; eauto.
       { (* value *)
         des; subst; unfold Integers.Int.repr; ss. }
       { split; ss. }
  - clarify. ss.
    solve_leibniz. clarify. ss.
    rewrite AssnState.Unary.sem_valueT_physical.
    unfold ite in *.
    unfold GV2int in INT.
    unfold Size.to_nat, Size.One in *.
    des_ifs; ss.
    + esplits; ss; eauto.
      rename n0 into wz.
      destruct wz; try omega.
      specialize (int_sizezero_cases i0). i.
      unfold const2GV in *. des_ifs. ss. clarify. ss.

      unfold val2GV.

      econs; ss; cycle 1.
      { apply list_forall2_nil. }
      econs; eauto.
      { (* value *)
        des; subst; unfold Integers.Int.repr; ss. }
      { ss. }
    + esplits; ss; eauto.
      rename n0 into wz.
      destruct wz; try omega.
      specialize (int_sizezero_cases i0). i.
      unfold const2GV in *. des_ifs. ss. clarify. ss.

      unfold val2GV.

      econs; ss; cycle 1.
      { apply list_forall2_nil. }
      econs; eauto.
      { (* value *)
        des; subst; unfold Integers.Int.repr; ss. }
      { ss. }
  - exploit LESSDEF; eauto.
Qed.

Lemma add_terminator_cond_br
      conf_src conf_tgt
      st_src st_tgt
      invst assnmem inv
      decision l1 l2
      id_src val_src gval_src
      id_tgt val_tgt gval_tgt
      (STATE: AssnState.Rel.sem
                conf_src conf_tgt st_src st_tgt
                invst assnmem inv)
      (VAL_SRC: getOperandValue
                  conf_src.(CurTargetData)
                  val_src
                  st_src.(EC).(Locals)
                  conf_src.(Globals) = Some gval_src)
      (VAL_TGT: getOperandValue
                  conf_tgt.(CurTargetData)
                  val_tgt
                  st_tgt.(EC).(Locals)
                  conf_tgt.(Globals) = Some gval_tgt)
      (DECIDE_SRC: decide_nonzero conf_src.(CurTargetData) gval_src decision)
      (DECIDE_TGT: decide_nonzero conf_tgt.(CurTargetData) gval_tgt decision):
  AssnState.Rel.sem
    conf_src conf_tgt
    st_src st_tgt
    invst assnmem
    (Postcond.add_terminator_cond
       inv
       (insn_br id_src val_src l1 l2)
       (insn_br id_tgt val_tgt l1 l2) (ite decision l1 l2)).
Proof.
  inv STATE.
  econs; eauto; ss.
  - eapply add_terminator_cond_br_unary; eauto.
  - eapply add_terminator_cond_br_unary; eauto.
Qed.

Lemma get_lessdef_spec
      ep assigns
      (IN: ExprPairSet.In ep (Postcond.Phinode.get_lessdef assigns)):
  exists phix phiv phity,
    <<IN: In (Postcond.Phinode.assign_intro phix phity phiv) assigns>> /\
    __guard__
      (<<DEFINEDNESS: ep = (Expr.value (ValueT.const (const_undef phity)),
                            Expr.value (ValueT.id (Tag.physical, phix)))>> \/
       <<PAIR1: ep = (Expr.value (ValueT.id (Tag.physical, phix)),
                      Expr.value (ValueT.lift Tag.previous phiv))>> \/
       <<PAIR2: ep = (Expr.value (ValueT.lift Tag.previous phiv),
                      Expr.value (ValueT.id (Tag.physical, phix)))>>).
Proof.
  cut
    (exists phix phiv phity,
        <<IN: In (Postcond.Phinode.assign_intro phix phity phiv) (rev assigns)>> /\
        __guard__
          (<<DEFINEDNESS: ep = (Expr.value (ValueT.const (const_undef phity)),
                            Expr.value (ValueT.id (Tag.physical, phix)))>> \/
           <<PAIR1: ep = (Expr.value (ValueT.id (Tag.physical, phix)),
                          Expr.value (ValueT.lift Tag.previous phiv))>> \/
           <<PAIR2: ep = (Expr.value (ValueT.lift Tag.previous phiv),
                          Expr.value (ValueT.id (Tag.physical, phix)))>>)).
  { i. des. esplits; eauto. apply in_rev. eauto. }
  unfold Postcond.Phinode.get_lessdef in IN.
  rewrite <- fold_left_rev_right in IN.
  rewrite <- fold_left_rev_right in IN.
  rewrite <- map_rev in IN.
  rewrite ExprPairSetFacts.union_iff in IN. des.
  { (* assigns *)
    induction (rev assigns); ss.
    { apply ExprPairSetFacts.empty_iff in IN. done. }
    destruct a. ss.
    repeat rewrite -> ExprPairSetFacts.add_iff in IN. des.
    - solve_leibniz.
      esplits; eauto. right. left. eauto.
    - solve_leibniz.
      esplits; eauto. right. right. eauto.
    - exploit IHl0; eauto. i. des. esplits; eauto.
  }
  { (* definedness *)
    induction (rev assigns); ss.
    { apply ExprPairSetFacts.empty_iff in IN. done. }
    destruct a. ss.
    repeat rewrite -> ExprPairSetFacts.add_iff in IN. des.
    - solve_leibniz. esplits; eauto. left. eauto.
    - exploit IHl0; eauto. i. des. esplits; eauto.
  }
Qed.

Lemma phinode_assign_sound
      conf phinodes b assigns
      locals locals'
      x ty v
      (ASSIGNS: forallb_map (Postcond.Phinode.resolve (fst b)) phinodes = Some assigns)
      (LOCALS': getIncomingValuesForBlockFromPHINodes
                  conf.(CurTargetData) phinodes b conf.(Globals) locals = Some locals')
      (UNIQUE_PHI: unique id_dec (List.map Postcond.Phinode.get_def assigns) = true)
      (ASSIGN_IN: In (Postcond.Phinode.assign_intro x ty v) assigns)
  : exists gv,
    <<VAL_V: getOperandValue conf.(CurTargetData) v locals conf.(Globals) = Some gv>> /\
    <<VAL_X: getOperandValue conf.(CurTargetData) (value_id x) locals' conf.(Globals) = Some gv>>.
Proof.
  revert_until b. induction phinodes; i; ss.
  { inv ASSIGNS. ss. }
  simtac. des.
  - inv ASSIGN_IN.
    assert (EQV: v = v0).
    { match goal with
      | [H1: getValueViaBlockFromValuels _ _ = Some v0,
         H2: lookupAL _ _ _ = Some v |- _] => clear -H1 H2
      end.
      unfold getValueViaBlockFromValuels in *.
      induction l0; ss; simtac.
      eapply IHl0; eauto.
    }
    subst. esplits; eauto.
    match goal with
    | [H:_ |- (if ?c then _ else _) = _ ] => destruct c; try done
    end.
  - exploit IHphinodes; eauto. i. des.
    esplits; eauto.
    fold id. destruct (x == id5); ss. subst.
    destruct (in_dec id_dec id5 (List.map Postcond.Phinode.get_def l2)); ss. contradict n.
    replace id5 with (Postcond.Phinode.get_def (Postcond.Phinode.assign_intro id5 ty v)); eauto.
    apply In_map; eauto.
Qed.

Lemma gv_chunks_match_typb_aux_implies_chunk_eq
      gv mcs
      (CHUNK: gv_chunks_match_typb_aux gv mcs)
  :
    <<CHUNK_EQ: List.map snd gv = mcs>>
.
Proof.
  exploit gv_chunks_match_typb_aux__gv_chunks_match_typ; eauto. i; des.
  exploit vm_matches_typ__eq__snd; eauto. i. clarify.
  rewrite util.snd_split__map_snd. ss.
Qed.

Lemma incomingPHINodes_lookup_chunk
      TD phinodes blk gl ls idgs
      (PHI: getIncomingValuesForBlockFromPHINodes TD phinodes blk gl ls = Some idgs)
      phix phity phiv assigns
      (ASSIGNS: In (Phinode.assign_intro phix phity phiv) assigns)
      gv
      (LOOKUP: lookupAL GenericValue idgs phix = Some gv)
      (RESOLVE: forallb_map (Phinode.resolve blk.(fst)) phinodes = Some assigns)
      (UNIQUE_PHI: unique id_dec (List.map Phinode.get_def assigns) = true)
      mcs
      (FLATTEN: flatten_typ TD phity = Some mcs)
  :
    <<CHUNK: gv_chunks_match_typb_aux gv mcs>>
    (* <<CHUNK: List.map snd gv = mcs>> *)
.
Proof.
  red.
  ginduction phinodes; ii; ss; clarify.
  des_ifs.
  ss.
  des_ifs_safe.
  destruct (phix == id5); ss.
  - clarify. des_ifs_safe.
    unfold gv_chunks_match_typb in *. des_ifs_safe.
    des.
    { clarify. }
    { repeat (des_bool; des; des_sumbool; clarify).
      exfalso. clear - UNIQUE_PHI ASSIGNS.
      apply UNIQUE_PHI. clear UNIQUE_PHI.
      ginduction l0; ii; ss.
      des; clarify; ss.
      - left; ss.
      - right. eapply IHl0; eauto.
    }
  - des_ifs_safe.
    repeat (des_bool; des; des_sumbool; clarify).
    { eapply IHphinodes; eauto. }
Qed.

Lemma phinodes_add_lessdef_sound
      conf st0 st1 gmax public
      l_to phinodes cmds terminator
      invst assnmem inv0
      assigns
      (STEP: switchToNewBasicBlock conf.(CurTargetData)
                                   (l_to, stmts_intro phinodes cmds terminator)
                                   st0.(EC).(CurBB)
                                   conf.(Globals)
                                   st0.(EC).(Locals) = Some st1.(EC).(Locals))
      (ASSIGNS: forallb_map (Postcond.Phinode.resolve st0.(EC).(CurBB).(fst)) phinodes = Some assigns)
      (UNIQUE_PHI: unique id_dec (List.map Postcond.Phinode.get_def assigns) = true)
      (STATE: AssnState.Unary.sem conf st1 invst assnmem gmax public inv0)
      (PREV: forall x, AssnState.Unary.sem_idT st0 invst (Tag.previous, x) =
                          lookupAL _ st0.(EC).(Locals) x)
  : AssnState.Unary.sem
      conf st1 invst assnmem gmax public
      (Hints.Assertion.update_lessdef (Postcond.postcond_phinodes_add_lessdef assigns) inv0).
Proof.
  econs; try by inv STATE.
  s. ii. apply ExprPairSet.union_1 in H.  des.
  { eapply STATE; eauto. }
  exploit get_lessdef_spec; eauto. i. des.
  unfold switchToNewBasicBlock in *.
  solve_match_bool. inv STEP. ss.
  destruct (CurBB (EC st0)). ss. des_ifs.
  exploit phinode_assign_sound; eauto; ss. i. des. ss.
  exploit opsem_props.OpsemProps.updateValuesForNewBlock_spec4; eauto.
  match goal with
  | [H: updateValuesForNewBlock _ _ = _ |- _] => rewrite H; i
  end.
  unguardH x0. des; subst; ss.
  - esplits.
    + unfold AssnState.Unary.sem_idT. ss. eauto.
    + exploit const2GV_undef; eauto. i. des.
      exploit incomingPHINodes_lookup_chunk; eauto. intro CHUNK; des.
      apply all_undef_lessdef_aux; eauto.
      { rewrite x3.
        apply gv_chunks_match_typb_aux_implies_chunk_eq in CHUNK.
        rewrite <- CHUNK. ss. }
      { clear - CHUNK.
        ginduction gv; ii; ss.
        des_ifs.
        unfold is_true in *. repeat (des_bool; des; ss; clarify).
        econs; eauto.
      }
  - esplits; [|reflexivity].
    assert (GV_VAL1: gv = val1).
    { unfold AssnState.Unary.sem_idT in VAL1. ss. congruence. }
    subst.
    unfold getOperandValue in VAL_V.
    destruct phiv; eauto.
    rewrite <- PREV in VAL_V. ss.
  - esplits; [|reflexivity].
    assert (GV_VAL1: gv = val1).
    { destruct phiv; ss.
      - rewrite <- PREV in VAL_V.
        unfold AssnState.Unary.sem_idT in *. ss. congruence.
      - congruence.
    }
    subst. eauto.
Qed.

Lemma phinodes_progress_getPhiNodeID_safe
      TD phinodes b gl locals locals' id assigns
      (GETINC: getIncomingValuesForBlockFromPHINodes TD phinodes b
                                                     gl locals = Some locals')
      (IN: In id (List.map getPhiNodeID phinodes))
      (RESOLVE : forallb_map (Postcond.Phinode.resolve (fst b)) phinodes = Some assigns)
  :
    <<IN: In id (List.map Postcond.Phinode.get_def assigns)>>.
Proof.
  revert_until gl. induction phinodes; ss. i. simtac.
  des; auto. exploit IHphinodes; eauto.
Qed.

Lemma locals_equiv_after_phinode
      conf l_to phinodes cmds tmn b assigns
      locals locals'
      (SWITCH: switchToNewBasicBlock conf.(CurTargetData)
                                     (l_to, stmts_intro phinodes cmds tmn)
                                     b conf.(Globals) locals = Some locals')
      (RESOLVE: forallb_map (Postcond.Phinode.resolve b.(fst)) phinodes = Some assigns)
  :
    <<EQUIV: locals_equiv_except (AtomSetImpl_from_list (List.map Postcond.Phinode.get_def assigns))
                                 locals locals'>>.
Proof.
  ii. unfold switchToNewBasicBlock in SWITCH. simtac.
  apply opsem_props.OpsemProps.updateValuesForNewBlock_spec5; ss.
  destruct (in_dec id_dec id0 (List.map getPhiNodeID phinodes)).
  - exploit phinodes_progress_getPhiNodeID_safe; eauto. i. des.
    contradict NOT_MEM. unfold not.
    apply eq_true_false_abs, AtomSetImpl_from_list_spec. eauto.
  - hexploit opsem_props.OpsemProps.getIncomingValuesForBlockFromPHINodes_spec8; eauto. i.
    exploit notin_lookupAL_None; eauto.
Qed.

Lemma IdTSet_from_list_spec':
  forall ids id0, IdTSet.mem id0 (IdTSetFacts.from_list ids) = false <-> ~ In id0 ids.
Proof.
  split; i.
  - ii. apply IdTSet_from_list_spec in H0. congruence.
  - apply not_true_iff_false. ii.
    apply IdTSet_from_list_spec in H0. eauto.
Qed.

Lemma lookupAL_reverse_aux
      X lbl l v
      (IN_REV: lookupAL X (List.map (fun x => (snd x, fst x)) l) lbl = Some v)
  : In (v, lbl) l.
Proof.
  revert IN_REV.
  induction l; ss.
  des_ifs.
  - i. clarify. left. destruct a; eauto.
  - i. right. eauto.
Qed.

Lemma resolve_eq_getValueViaLabelFromValuels
      l_from phinodes passigns
      p ty vls v
      (RESOLVE : forallb_map (Phinode.resolve l_from) phinodes = Some passigns)
      (UNIQUE_ID : unique id_dec (List.map Phinode.get_def passigns) = true)
      (IN_PHIS: In (insn_phi p ty vls) phinodes)
      (GET_VALUE: getValueViaLabelFromValuels vls l_from = Some v)
  : In (Phinode.assign_intro p ty v) passigns.
Proof.
  revert dependent passigns.
  revert IN_PHIS.
  induction phinodes; ss; i.
  des_ifs. des.
  - subst. ss. des_ifs.
    assert (XX: v = v0).
    { clear -GET_VALUE Heq1.
      induction vls; ss.
      des_ifs. exploit IHvls; eauto.
    }
    subst. eauto.
  - exploit IHphinodes; eauto.
    + ss. des_bool. des. eauto.
    + i. ss. right. eauto.
Qed.

Lemma wf_const_valid_ptr
      conf st0 assnmem phinodes gmax public
  (MEM : AssnMem.Unary.sem conf gmax public (Mem st0) assnmem)
  (WF_SUBSET : Forall
                (fun phi : phinode =>
                 exists b : block, phinodeInBlockB phi b /\ blockInFdefB b (CurFunction (EC st0))) phinodes)
  reg val' t1 vls1 const5
  nextbb
  (WF_INSN: wf_insn (CurSystem conf)
                    conf
                    (CurFunction (EC st0)) nextbb (insn_phinode (insn_phi reg t1 vls1)))
  (INCOMING_IN : In (insn_phi reg t1 vls1) phinodes)
  (INCOMING_VALUES : getValueViaLabelFromValuels vls1 (getBlockLabel (CurBB (EC st0))) = Some (value_const const5))
  (INCOMING_GET : const2GV (CurTargetData conf) (Globals conf) const5 = Some val')
  :
    <<VALID_PTR: memory_props.MemProps.valid_ptrs (gmax + 1)%positive val'>>
.
Proof.
  move WF_SUBSET at bottom.
  rewrite List.Forall_forall in WF_SUBSET.
  specialize (WF_SUBSET (insn_phi reg t1 vls1) INCOMING_IN). des.

  inv WF_INSN. clear H7 H8.
  exploit H6.
  {
    instantiate (1:= value_const const5).
    exploit infrastructure_props.getValueViaLabelFromValuels__InValueList; eauto.
    intros IN_CONST.
    clear - IN_CONST.
    {
      induction vls1; ss.
      des_ifs.
      des; clarify.
      - left; ss.
      - right; ss. eapply IHvls1; eauto.
    }
  (* split_combine *)
  (* in_combine_l *)
  }
  intro WF_VALUE. ss. des.

  inv WF_VALUE. destruct conf; ss. des_ifs.
  symmetry in INCOMING_GET.

  inv MEM.
  clear WF PRIVATE_PARENT MEM_PARENT UNIQUE_PARENT_MEM
        UNIQUE_PARENT_GLOBALS UNIQUE_PRIVATE_PARENT NEXTBLOCK.
  rename GLOBALS into WF_GLOBALS.
  eapply wf_globals_eq in WF_GLOBALS.

  exploit MemAux.wf_globals_const2GV; eauto.
  eapply wf_globals_eq; eauto.
Qed.

Lemma wf_const_diffblock
      conf st0 assnmem phinodes gmax public
  (MEM : AssnMem.Unary.sem conf gmax public (Mem st0) assnmem)
  (WF_SUBSET : Forall
                (fun phi : phinode =>
                 exists b : block, phinodeInBlockB phi b /\ blockInFdefB b (CurFunction (EC st0))) phinodes)
  val reg val' t1 vls1 const5
  nextbb
  (WF_INSN: wf_insn (CurSystem conf)
                    conf
                    (CurFunction (EC st0)) nextbb (insn_phinode (insn_phi reg t1 vls1)))
  (GLOBALS : forall b : Values.block, In b (GV2blocks val) -> (gmax < b)%positive)
  (INCOMING_IN : In (insn_phi reg t1 vls1) phinodes)
  (INCOMING_VALUES : getValueViaLabelFromValuels vls1 (getBlockLabel (CurBB (EC st0))) = Some (value_const const5))
  (INCOMING_GET : const2GV (CurTargetData conf) (Globals conf) const5 = Some val')
  :
    <<DIFFBLOCK: AssnState.Unary.sem_diffblock conf val val'>>
.
Proof.
  ii.
  exploit wf_const_valid_ptr; eauto; []; ii; des.
  eapply valid_ptr_globals_diffblock; eauto.
Qed.

Lemma wf_phinodes_wf_insn
      reg t1 vls1 phinodes5
      (INCOMING_IN: In (insn_phi reg t1 vls1) phinodes5)
      CurFunction0 CurSystem0 stmts md
      (WF: wf_phinodes CurSystem0 md CurFunction0
                       stmts phinodes5)
  :
    <<WF: wf_insn CurSystem0 md CurFunction0 stmts (insn_phinode (insn_phi reg t1 vls1))>>
.
Proof.
  ginduction phinodes5; ii; ss.
  inv WF.
  des.
  - clarify.
  - eapply IHphinodes5; eauto.
Qed.

Lemma wf_ec_lookup_wf_ec
      st0
      l_to
      conf
      phinodes5 cmds_src terminator_src
      (LOOKUP: lookupAL stmts (get_blocks (CurFunction (EC st0))) l_to =
               Some (stmts_intro phinodes5 cmds_src terminator_src))
      (WF_FDEF: wf_fdef (CurSystem conf) (OpsemAux.module_of_conf conf) (CurFunction (EC st0)))
      (WF_EC: OpsemAux.wf_EC (EC st0))
      locals_src
  :
    <<WF: OpsemAux.wf_EC
            {|
              CurFunction := CurFunction (EC st0);
              CurBB := (l_to, stmts_intro phinodes5 cmds_src terminator_src);
              CurCmds := cmds_src;
              Terminator := terminator_src;
              Locals := locals_src;
              Allocas := Allocas (EC st0) |}>>
.
Proof.
  inv WF_EC.
  econs; ss; eauto.
  - unfold get_blocks in *. des_ifs.
    destruct st0; ss. destruct EC0; ss. clarify.
    clear - LOOKUP.
    (* TODO: pull out lemma? Use Set Printing All and then pull out, otherwise type checking fails *)
    ginduction blocks5; ii; ss.
    apply orb_true_iff.
    des_ifs.
    + left. unfold blockEqB. unfold sumbool2bool. des_ifs.
    + right. eapply IHblocks5; eauto.
  - autounfold. ss.
    apply sublist_refl.
  - unfold terminatorEqB. unfold sumbool2bool. des_ifs.
Qed.

Hint Unfold OpsemAux.get_cmds_from_block. (* TODO: move to definition point *)
Hint Unfold OpsemAux.module_of_conf. (* TODO: move to definition point *)

(* st0 is the state before entering "phinodes". *)
(* Therefore, phinodes in st0.(EC).(CurBB) <> "phinodes". *)
(* st0.(EC).(CurBB) is the block before "phinodes". *)
(* "nextbb" represents block of the "phinodes". *)
(* It is introduced for "WF_PHIS" only. *)
Lemma phinodes_unique_preserved_except
      conf st0 inv0 assnmem invst
      l_to phinodes cmds terminator locals l0
      gmax public
      (STATE : AssnState.Unary.sem conf st0 invst assnmem gmax public inv0)
      (MEM : AssnMem.Unary.sem conf gmax public st0.(Mem) assnmem)
      (RESOLVE : forallb_map (Phinode.resolve (fst (CurBB (EC st0)))) phinodes = Some l0)
      (UNIQUE_ID : unique id_dec (List.map Phinode.get_def l0) = true)
      (STEP : switchToNewBasicBlock (CurTargetData conf) (l_to, stmts_intro phinodes cmds terminator)
                                    (CurBB (EC st0)) (Globals conf) (Locals (EC st0)) = Some locals)
      nextbb
      (WF_PHIS: wf_phinodes (CurSystem conf) conf (CurFunction (EC st0)) nextbb phinodes)
      (WF_SUBSET: List.Forall (fun phi =>
                          exists b,
                            insnInBlockB (insn_phinode phi) b
                            /\ blockInFdefB b (CurFunction (EC st0))) phinodes)
  : unique_preserved_except conf inv0 assnmem.(AssnMem.Unary.unique_parent)
                                               (mkState (mkEC
                                                           st0.(EC).(CurFunction)
                                                                      (l_to, stmts_intro phinodes cmds terminator)
                                                                      cmds
                                                                      terminator
                                                                      locals
                                                                      st0.(EC).(Allocas))
                                                        st0.(ECS) st0.(Mem))
                                               gmax
                                               (AtomSetImpl.union (AtomSetImpl_from_list (List.map Phinode.get_def l0))
                                                                  (AtomSetImpl_from_list (filter_map Phinode.get_use l0))).
Proof.
  econs; ss.
  - i.
    rewrite <- AtomSetFacts.not_mem_iff in *.
    hexploit notin_union_1; eauto. intro NOT_IN_DEF.
    hexploit notin_union_2; eauto. intro NOT_IN_USE.
    rewrite AtomSetImpl_from_list_spec2 in *.

    inv STATE.
    rewrite <- AtomSetFacts.mem_iff in *.
    exploit UNIQUE; eauto. intro UNIQUE_U.

    unfold switchToNewBasicBlock in STEP. des_ifs.
    inv UNIQUE_U.
    econs; eauto; ss.
    + rewrite opsem_props.OpsemProps.updateValuesForNewBlock_spec7'; eauto.
      eapply opsem_props.OpsemProps.getIncomingValuesForBlockFromPHINodes_spec8; eauto.
      ss. ii.
      exploit phinodes_progress_getPhiNodeID_safe; eauto.
    + i.
      destruct (AtomSetImpl.mem reg (dom l1)) eqn:REG_MEM.
      { rewrite <- AtomSetFacts.mem_iff in REG_MEM.
        hexploit indom_lookupAL_Some; eauto. i. des.
        exploit opsem_props.OpsemProps.getIncomingValuesForBlockFromPHINodes_spec9'; eauto.
        intros INCOMING. destruct INCOMING as [t1 [vls1 [v [INCOMING_IN [INCOMING_VALUES INCOMING_GET]]]]].
        (* better way to name it?? *)

        exploit resolve_eq_getValueViaLabelFromValuels; eauto. intro IN_PASSIGNS.
        rewrite opsem_props.OpsemProps.updateValuesForNewBlock_spec6' in *; eauto. clarify.
        destruct v as [y|].
        - ss. eapply LOCALS; [| eauto].
          ii. subst.
          apply NOT_IN_USE. clarify.
          eapply filter_map_spec; eauto.
        - eapply wf_const_diffblock; eauto.
          eapply wf_phinodes_wf_insn; eauto.
      }
      { rewrite <- AtomSetFacts.not_mem_iff in REG_MEM.
        rewrite opsem_props.OpsemProps.updateValuesForNewBlock_spec7' in VAL'; eauto.
      }
  - inv STATE.
    i. unfold switchToNewBasicBlock in *.
    des_ifs.
    destruct (AtomSetImpl.mem x (dom l1)) eqn:REG_MEM.
    { rewrite <- AtomSetFacts.mem_iff in REG_MEM.
      hexploit indom_lookupAL_Some; eauto. i. des.
      exploit opsem_props.OpsemProps.getIncomingValuesForBlockFromPHINodes_spec9'; eauto. i. des.
      ss.

      exploit phinode_assign_sound; eauto.
      { eapply resolve_eq_getValueViaLabelFromValuels; eauto. }
      i. des.
      apply opsem_props.OpsemProps.updateValuesForNewBlock_spec4 with (lc:=st0.(EC).(Locals)) in VAL_X.
      clarify.
      destruct v as [y|]; ss.
      - eapply UNIQUE_PARENT_LOCAL; eauto.
      - hexploit wf_const_valid_ptr; eauto.
        { eapply wf_phinodes_wf_insn; eauto.
        }
        intro VALID_PTR; des.
        inv MEM.
        eapply valid_ptr_globals_diffblock_with_blocks; eauto.
    }
    { rewrite <- AtomSetFacts.not_mem_iff in REG_MEM.
      rewrite opsem_props.OpsemProps.updateValuesForNewBlock_spec7' in PTR; eauto.
    }
  - inv MEM. eauto.
  - inv MEM. eauto.
Unshelve.
ss.
Qed.

Lemma switchToNewBasicBlock_wf
      conf mem locals locals'
      l_from l_to stmts
      (WF_LOCAL : memory_props.MemProps.wf_lc mem locals)
      (STEP: switchToNewBasicBlock (CurTargetData conf) (l_to, stmts)
                                   l_from (Globals conf) locals = Some locals')
      gmax public assnmem
      (* st0 invst0 inv0 *)
      (* (STATE: AssnState.Unary.sem conf st0 invst0 assnmem0 gmax public inv0) *)
      (MEM : AssnMem.Unary.sem conf gmax public mem assnmem)
  : memory_props.MemProps.wf_lc mem locals'.
Proof.
  unfold switchToNewBasicBlock in *. des_ifs.
  intros x gvx Hx.
  destruct (AtomSetImpl.mem x (dom l0)) eqn:REG_MEM.
  { rewrite <- AtomSetFacts.mem_iff in REG_MEM.
    hexploit indom_lookupAL_Some; eauto. i. des.
    exploit opsem_props.OpsemProps.getIncomingValuesForBlockFromPHINodes_spec9'; eauto. i. des.
    (* assert(H2:= H). *)
    apply opsem_props.OpsemProps.updateValuesForNewBlock_spec4 with (lc:=locals) in H. clarify.
    {
      destruct v; ss.
      - eapply WF_LOCAL; eauto.
      - inv MEM.
        exploit MemAux.wf_globals_const2GV; eauto; []; ii; des.
        unfold memory_props.MemProps.wf_Mem in WF. des.
        clear - WF0 x4.
        eapply memory_props.MemProps.valid_ptrs__trans; eauto.
        eapply Pos.lt_succ_r.
        replace (gmax + 1)%positive with (Pos.succ gmax); cycle 1.
        { destruct gmax; ss. }
        rewrite <- Pos.succ_lt_mono; eauto.
    }
  }
  { rewrite <- AtomSetFacts.not_mem_iff in REG_MEM.
    rewrite opsem_props.OpsemProps.updateValuesForNewBlock_spec7' in Hx; eauto.
  }
Qed.

Lemma lookup_implies_wf_subset
      st0 l_to phinodes cmds terminator
      (STMT : lookupAL stmts (get_blocks (CurFunction (EC st0))) l_to =
                  Some (stmts_intro phinodes cmds terminator))
  :
    <<WF_SUBSET: List.Forall
      (fun phi : phinode =>
         exists b : block, insnInBlockB (insn_phinode phi) b /\ blockInFdefB b (CurFunction (EC st0)))
      phinodes>>
.
Proof.
  destruct st0; ss. destruct EC0; ss. destruct CurFunction0; ss.
  clear - phinodes STMT.
  red.
  rewrite List.Forall_forall.
  i.
  induction blocks5; ii; ss.
  destruct a; ss.
  rename s into __s__.
  des_ifs.
  - esplits; eauto; cycle 1.
    + unfold is_true.
      rewrite orb_true_iff.
      left. instantiate (1:= (l0, stmts_intro phinodes cmds terminator)).
      rewrite infrastructure_props.blockEqB_refl. ss.
    + ss. clear - H.
      apply infrastructure_props.In_InPhiNodesB; ss.
  - exploit IHblocks5; eauto; []; ii; des.
    esplits; eauto.
    unfold is_true.
    rewrite orb_true_iff.
    right.
    ss.
Qed.

Lemma postcond_phinodes_sound
      m_src conf_src st0_src phinodes_src cmds_src terminator_src locals_src
      m_tgt conf_tgt st0_tgt phinodes_tgt cmds_tgt terminator_tgt locals_tgt
      invst0 assnmem inv0 inv1
      l_from l_to
      (CONF: AssnState.valid_conf m_src m_tgt conf_src conf_tgt)
      (CMD_SRC: st0_src.(EC).(CurCmds) = [])
      (CMD_TGT: st0_tgt.(EC).(CurCmds) = [])
      (L_SRC: st0_src.(EC).(CurBB).(fst) = l_from)
      (L_TGT: st0_tgt.(EC).(CurBB).(fst) = l_from)
      (STMT_SRC: lookupAL stmts st0_src.(EC).(CurFunction).(get_blocks) l_to =
                 Some (stmts_intro phinodes_src cmds_src terminator_src))
      (STMT_TGT: lookupAL stmts st0_tgt.(EC).(CurFunction).(get_blocks) l_to =
                 Some (stmts_intro phinodes_tgt cmds_tgt terminator_tgt))
      (POSTCOND: Postcond.postcond_phinodes l_from phinodes_src phinodes_tgt inv0 = Some inv1)
      (STATE: AssnState.Rel.sem conf_src conf_tgt st0_src st0_tgt invst0 assnmem inv0)
      (MEM: AssnMem.Rel.sem conf_src conf_tgt st0_src.(Mem) st0_tgt.(Mem) assnmem)
      (STEP_SRC: switchToNewBasicBlock
                   conf_src.(CurTargetData)
                   (l_to, stmts_intro phinodes_src cmds_src terminator_src)
                   st0_src.(EC).(CurBB)
                   conf_src.(Globals)
                   st0_src.(EC).(Locals)
                 = Some locals_src)
      (STEP_TGT: switchToNewBasicBlock
                   conf_tgt.(CurTargetData)
                   (l_to, stmts_intro phinodes_tgt cmds_tgt terminator_tgt)
                   st0_tgt.(EC).(CurBB)
                   conf_tgt.(Globals)
                   st0_tgt.(EC).(Locals)
                 = Some locals_tgt):
  exists invst1,
    <<STATE: AssnState.Rel.sem
               conf_src conf_tgt
               (mkState
                  (mkEC
                     st0_src.(EC).(CurFunction)
                     (l_to, stmts_intro phinodes_src cmds_src terminator_src)
                     cmds_src
                     terminator_src
                     locals_src
                     st0_src.(EC).(Allocas))
                  st0_src.(ECS)
                  st0_src.(Mem))
               (mkState
                  (mkEC
                     st0_tgt.(EC).(CurFunction)
                     (l_to, stmts_intro phinodes_tgt cmds_tgt terminator_tgt)
                     cmds_tgt
                     terminator_tgt
                     locals_tgt
                     st0_tgt.(EC).(Allocas))
                  st0_tgt.(ECS)
                  st0_tgt.(Mem))
               invst1 assnmem inv1>>.
Proof.
  unfold Postcond.postcond_phinodes in *.
  unfold Postcond.postcond_phinodes_assigns in *.
  clarify.
  des_ifs_safe ss. clarify.
  des_bool. des.
  (* simtac. *) (* TODO: simtac LOSES INFORMATION on PHIS_SRC/PHIS_TGT *)
  (* TODO: REMOVE ALL SIMTAC *)
  exploit snapshot_sound; eauto. i. des.

  exploit forget_stack_sound; [eauto|eauto|eauto|eauto|eauto|eauto|eauto|..].
  { instantiate (1 := mkState (mkEC _ _ _ _ _ _) _ _). econs; s; eauto.
    eapply locals_equiv_after_phinode; eauto.
  }
  { instantiate (1 := mkState (mkEC _ _ _ _ _ _) _ _). econs; s; eauto.
    eapply locals_equiv_after_phinode; eauto.
    rewrite L_TGT. eauto.
  }
  { inv STATE_SNAPSHOT. inv MEM.
    instantiate (6:= (_, stmts_intro phinodes_src _ _)).
    eapply phinodes_unique_preserved_except; eauto.
    { instantiate (1:= (l_to, (stmts_intro phinodes_src cmds_src terminator_src))).
      inv STATE. inv SRC.
      clear - STMT_SRC WF_EC WF_FDEF.
      rpapply typings_props.wf_fdef__wf_phinodes; eauto. Undo 1.
      destruct st0_src; ss. destruct EC0; ss. destruct CurBB0; ss. destruct s; ss.
      eapply typings_props.wf_fdef__wf_phinodes; eauto.
      rpapply infrastructure_props.lookupBlock_blocks_inv; try eassumption. Undo 1.
      destruct CurFunction0.
      rpapply infrastructure_props.lookupBlock_blocks_inv; eauto.
    }
    { eapply lookup_implies_wf_subset; eauto. }
  }
  { inv STATE_SNAPSHOT. inv MEM.
    instantiate (6:= (_, stmts_intro phinodes_tgt _ _)).
    eapply phinodes_unique_preserved_except; eauto.
    { rewrite L_TGT. ss. }
    { instantiate (1:= (l_to, (stmts_intro phinodes_tgt cmds_tgt terminator_tgt))).
      inv STATE. inv TGT.
      clear - STMT_TGT WF_EC WF_FDEF.
      rpapply typings_props.wf_fdef__wf_phinodes; eauto. Undo 1.
      destruct st0_tgt; ss. destruct EC0; ss. destruct CurBB0; ss. destruct s; ss.
      eapply typings_props.wf_fdef__wf_phinodes; eauto.
      rpapply infrastructure_props.lookupBlock_blocks_inv; try eassumption. Undo 1.
      destruct CurFunction0.
      rpapply infrastructure_props.lookupBlock_blocks_inv; eauto.
    }
    { eapply lookup_implies_wf_subset; eauto. }
  }
  { eapply switchToNewBasicBlock_wf; try exact STEP_SRC; eauto. apply STATE. apply MEM. }
  { eapply switchToNewBasicBlock_wf; try exact STEP_TGT; eauto. apply STATE. apply MEM. }
  { ss. }
  { ss. }
  { apply STATE. }
  { apply STATE. }
  { apply STATE. }
  { apply STATE. }
  { apply STATE. }
  { eapply wf_ec_lookup_wf_ec; eauto; try apply STATE. }
  { eapply wf_ec_lookup_wf_ec; eauto; try apply STATE. }
  intros STATE_FORGET. des.
  inv STATE_FORGET.
  exploit phinodes_add_lessdef_sound; try exact SRC; eauto; i.
  exploit phinodes_add_lessdef_sound; try exact TGT; eauto; i.
  { rewrite L_TGT. eauto. }
  exploit reduce_maydiff_sound; swap 1 2.
  { instantiate (1 := Hints.Assertion.mk _ _ _). econs; eauto. }
  { eauto. }
  { eauto. }
  intro STATE_MAYDIFF. exact STATE_MAYDIFF.
Qed.