(* 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 Qhomographic_sign.
Require Export Qhomographic_Qpositive_to_Qpositive.
Require Export Qhomographic_sign_properties.

Definition new_a (a b c d : Z) (p : Qpositive)
  (H_Qhomographic_sg_denom_nonzero : Qhomographic_sg_denom_nonzero c d p) :=
  fst
    (fst (snd (Qhomographic_sign a b c d p H_Qhomographic_sg_denom_nonzero))).

Definition new_b (a b c d : Z) (p : Qpositive)
  (H_Qhomographic_sg_denom_nonzero : Qhomographic_sg_denom_nonzero c d p) :=
  fst
    (snd
       (fst
          (snd (Qhomographic_sign a b c d p H_Qhomographic_sg_denom_nonzero)))).

Definition new_c (a b c d : Z) (p : Qpositive)
  (H_Qhomographic_sg_denom_nonzero : Qhomographic_sg_denom_nonzero c d p) :=
  fst
    (snd
       (snd
          (fst
             (snd
                (Qhomographic_sign a b c d p H_Qhomographic_sg_denom_nonzero))))).

Definition new_d (a b c d : Z) (p : Qpositive)
  (H_Qhomographic_sg_denom_nonzero : Qhomographic_sg_denom_nonzero c d p) :=
  snd
    (snd
       (snd
          (fst
             (snd
                (Qhomographic_sign a b c d p H_Qhomographic_sg_denom_nonzero))))).

Definition new_p (a b c d : Z) (p : Qpositive)
  (H_Qhomographic_sg_denom_nonzero : Qhomographic_sg_denom_nonzero c d p) :=
  snd (snd (Qhomographic_sign a b c d p H_Qhomographic_sg_denom_nonzero)).

Lemma Qhomographic_Qpositive_to_Q_homographicAcc_pos_1 :
 forall (a b c d : Z) (p : Qpositive)
   (H_Qhomographic_sg_denom_nonzero : Qhomographic_sg_denom_nonzero c d p),
 (a * d)%Z <> (b * c)%Z ->
 h_sign a b c d p H_Qhomographic_sg_denom_nonzero = 1%Z ->
 (0 <
  Z.sgn
    (new_a a b c d p H_Qhomographic_sg_denom_nonzero +
     new_b a b c d p H_Qhomographic_sg_denom_nonzero))%Z ->
 homographicAcc (new_a a b c d p H_Qhomographic_sg_denom_nonzero)
   (new_b a b c d p H_Qhomographic_sg_denom_nonzero)
   (new_c a b c d p H_Qhomographic_sg_denom_nonzero)
   (new_d a b c d p H_Qhomographic_sg_denom_nonzero)
   (new_p a b c d p H_Qhomographic_sg_denom_nonzero).
Proof.
 intros a b c d p H_hsign ad_neq_bc l1_eq_one z.
 set (na := new_a a b c d p H_hsign) in *.
 set (nb := new_b a b c d p H_hsign) in *.
 set (nc := new_c a b c d p H_hsign) in *.
 set (nd := new_d a b c d p H_hsign) in *.
 set (l3 := new_p a b c d p H_hsign) in *.
 assert
  (H : Qhomographic_sign a b c d p H_hsign = (1%Z, (na, (nb, (nc, nd)), l3))).
 unfold na, nb, nc, nd, l3 in |- *.
 rewrite <- l1_eq_one.
 unfold new_a, new_b, new_c, new_d, new_p in |- *.
 replace (h_sign a b c d p H_hsign) with
  (fst (Qhomographic_sign a b c d p H_hsign)); [ idtac | reflexivity ];
  repeat rewrite <- pair_1; reflexivity.
      destruct l3 as [p0| p0| ].
      (* l3 = (nR p0) *)
      apply homographicAcc_wf.
      apply Zsgn_12.
      assumption.

      generalize (sg_pos_1 a b c d p H_hsign na nb nc nd (nR p0) H).
      intros.
      case H0.
      intro.
      elim a0.
      intros.
      assumption.
      intros.
      apply False_ind.
      elim a0.
      intros.
      generalize (Zsgn_12 (na + nb) z).
      intro.
      apply Z.lt_irrefl with 0%Z.
      apply Z.lt_trans with (na + nb)%Z.
      assumption.
      assumption.
      generalize (sg_pos_2 a b c d p H_hsign na nb nc nd (nR p0) H).
      intro.
      case H0.
      intro.
      case s.
      intro.
      elim a0.
      intros; assumption.
      intro.
      apply False_ind.
      elim a0.
      intros.
      elim H2.
      intros.
      apply Z.lt_irrefl with 0%Z.
      apply Z.lt_le_trans with (na + nb)%Z.
      apply Zsgn_12.
      assumption.
      rewrite Zplus_0_r_reverse with 0%Z.
      apply Zplus_le_compat.
      assumption.
      assumption.
      intro.
      discriminate e.
      generalize (sg_pos_2 a b c d p H_hsign na nb nc nd (nR p0) H).
      intro.
      case H0.
      intro.
      case s.
      intro.
      elim a0.
      intros.
      elim H2.
      intros.
      assumption.
      intro.
      apply False_ind.
      elim a0.
      intros.
      elim H2.
      intros.
      apply Z.lt_irrefl with 0%Z.
      apply Z.lt_le_trans with (na + nb)%Z.
      apply Zsgn_12.
      assumption.
      rewrite Zplus_0_r_reverse with 0%Z.
      apply Zplus_le_compat.
      assumption.
      assumption.
      intro.
      discriminate e.
      generalize (sg_pos_2 a b c d p H_hsign na nb nc nd (nR p0) H).
      intro.
      case H0.
      intro.
      case s.
      intro.
      elim a0.
      intros.
      elim H2.
      intros.
      elim H4.
      intros.
      assumption.
      intro.
      apply False_ind.
      elim a0.
      intros.
      elim H2.
      intros.
      apply Z.lt_irrefl with 0%Z.
      apply Z.lt_le_trans with (na + nb)%Z.
      apply Zsgn_12.
      assumption.
      rewrite Zplus_0_r_reverse with 0%Z.
      apply Zplus_le_compat.
      assumption.
      assumption.
      intro.
      discriminate e.
      generalize (sg_pos_2 a b c d p H_hsign na nb nc nd (nR p0) H).
      intro.
      case H0.
      intro.
      case s.
      intro.
      elim a0.
      intros.
      elim H2.
      intros.
      elim H4.
      intros.
      assumption.
      intro.
      apply False_ind.
      elim a0.
      intros.
      elim H2.
      intros.
      apply Z.lt_irrefl with 0%Z.
      apply Z.lt_le_trans with (na + nb)%Z.
      apply Zsgn_12.
      assumption.
      rewrite Zplus_0_r_reverse with 0%Z.
      apply Zplus_le_compat.
      assumption.
      assumption.
      intro.
      discriminate e.
      (* l3 = (dL p0) *)
      apply homographicAcc_wf.
      apply Zsgn_12.
      assumption.

      generalize (sg_pos_1 a b c d p H_hsign na nb nc nd (dL p0) H).
      intros.
      case H0.
      intro.
      elim a0.
      intros.
      assumption.
      intros.
      apply False_ind.
      elim a0.
      intros.
      generalize (Zsgn_12 (na + nb) z).
      intro.
      apply Z.lt_irrefl with 0%Z.
      apply Z.lt_trans with (na + nb)%Z.
      assumption.
      assumption.
      generalize (sg_pos_2 a b c d p H_hsign na nb nc nd (dL p0) H).
      intro.
      case H0.
      intro.
      case s.
      intro.
      elim a0.
      intros; assumption.
      intro.
      apply False_ind.
      elim a0.
      intros.
      elim H2.
      intros.
      apply Z.lt_irrefl with 0%Z.
      apply Z.lt_le_trans with (na + nb)%Z.
      apply Zsgn_12.
      assumption.
      rewrite Zplus_0_r_reverse with 0%Z.
      apply Zplus_le_compat.
      assumption.
      assumption.
      intro.
      discriminate e.
      generalize (sg_pos_2 a b c d p H_hsign na nb nc nd (dL p0) H).
      intro.
      case H0.
      intro.
      case s.
      intro.
      elim a0.
      intros.
      elim H2.
      intros.
      assumption.
      intro.
      apply False_ind.
      elim a0.
      intros.
      elim H2.
      intros.
      apply Z.lt_irrefl with 0%Z.
      apply Z.lt_le_trans with (na + nb)%Z.
      apply Zsgn_12.
      assumption.
      rewrite Zplus_0_r_reverse with 0%Z.
      apply Zplus_le_compat.
      assumption.
      assumption.
      intro.
      discriminate e.
      generalize (sg_pos_2 a b c d p H_hsign na nb nc nd (dL p0) H).
      intro.
      case H0.
      intro.
      case s.
      intro.
      elim a0.
      intros.
      elim H2.
      intros.
      elim H4.
      intros.
      assumption.
      intro.
      apply False_ind.
      elim a0.
      intros.
      elim H2.
      intros.
      apply Z.lt_irrefl with 0%Z.
      apply Z.lt_le_trans with (na + nb)%Z.
      apply Zsgn_12.
      assumption.
      rewrite Zplus_0_r_reverse with 0%Z.
      apply Zplus_le_compat.
      assumption.
      assumption.
      intro.
      discriminate e.
      generalize (sg_pos_2 a b c d p H_hsign na nb nc nd (dL p0) H).
      intro.
      case H0.
      intro.
      case s.
      intro.
      elim a0.
      intros.
      elim H2.
      intros.
      elim H4.
      intros.
      assumption.
      intro.
      apply False_ind.
      elim a0.
      intros.
      elim H2.
      intros.
      apply Z.lt_irrefl with 0%Z.
      apply Z.lt_le_trans with (na + nb)%Z.
      apply Zsgn_12.
      assumption.
      rewrite Zplus_0_r_reverse with 0%Z.
      apply Zplus_le_compat.
      assumption.
      assumption.
      intro.
      discriminate e.
      (* l3 = One *)
      apply homographicacc0.
      reflexivity.
      apply Zsgn_12.
      assumption.
      generalize (sg_pos_1 a b c d p H_hsign na nb nc nd One H).
      intros.
      case H0.
      intro.
      elim a0.
      intros.
      assumption.
      intros.
      apply False_ind.
      elim a0.
      intros.
      generalize (Zsgn_12 (na + nb) z).
      intro.
      apply Z.lt_irrefl with 0%Z.
      apply Z.lt_trans with (na + nb)%Z.
      assumption.
      assumption.
Defined.

Lemma Qhomographic_Qpositive_to_Q_homographicAcc_pos_2 :
 forall (a b c d : Z) (p : Qpositive)
   (H_Qhomographic_sg_denom_nonzero : Qhomographic_sg_denom_nonzero c d p),
 (a * d)%Z <> (b * c)%Z ->
 h_sign a b c d p H_Qhomographic_sg_denom_nonzero = 1%Z ->
 (Z.sgn
    (new_a a b c d p H_Qhomographic_sg_denom_nonzero +
     new_b a b c d p H_Qhomographic_sg_denom_nonzero) <= 0)%Z ->
 homographicAcc (- new_a a b c d p H_Qhomographic_sg_denom_nonzero)
   (- new_b a b c d p H_Qhomographic_sg_denom_nonzero)
   (- new_c a b c d p H_Qhomographic_sg_denom_nonzero)
   (- new_d a b c d p H_Qhomographic_sg_denom_nonzero)
   (new_p a b c d p H_Qhomographic_sg_denom_nonzero).
Proof.
 intros a b c d p H_hsign ad_neq_bc l1_eq_one z.
 set (na := new_a a b c d p H_hsign) in *.
 set (nb := new_b a b c d p H_hsign) in *.
 set (nc := new_c a b c d p H_hsign) in *.
 set (nd := new_d a b c d p H_hsign) in *.
 set (l3 := new_p a b c d p H_hsign) in *.
 assert
  (H : Qhomographic_sign a b c d p H_hsign = (1%Z, (na, (nb, (nc, nd)), l3))).
 unfold na, nb, nc, nd, l3 in |- *.
 rewrite <- l1_eq_one.
 unfold new_a, new_b, new_c, new_d, new_p in |- *.
 replace (h_sign a b c d p H_hsign) with
  (fst (Qhomographic_sign a b c d p H_hsign)); [ idtac | reflexivity ];
  repeat rewrite <- pair_1; reflexivity.
      destruct l3 as [p0| p0| ].
      (* l3 = (nR p0) *)
      apply homographicAcc_wf.
      generalize (sg_pos_1 a b c d p H_hsign na nb nc nd (nR p0) H).
      intro.
      case H0.
      intros.
      apply False_ind.
      elim a0.
      intros.
      generalize (Zsgn_14 _ z).
      intro.
      apply Z.lt_irrefl with 0%Z.
      apply Z.lt_le_trans with (na + nb)%Z.
      assumption.
      assumption.
      intro.
      elim a0.
      intros.
      rewrite <- Zopp_plus_distr.
      apply Zlt_neg_opp.
      assumption.
      generalize (sg_pos_1 a b c d p H_hsign na nb nc nd (nR p0) H).
      intro.
      case H0.
      intros.
      apply False_ind.
      elim a0.
      intros.
      generalize (Zsgn_14 _ z).
      intro.
      apply Z.lt_irrefl with 0%Z.
      apply Z.lt_le_trans with (na + nb)%Z.
      assumption.
      assumption.
      intro.
      elim a0.
      intros.
      rewrite <- Zopp_plus_distr.
      apply Zlt_neg_opp.
      assumption.
      generalize (sg_pos_2 a b c d p H_hsign na nb nc nd (nR p0) H).
      intro.
      case H0.
      intro.
      case s.
      intro.
      elim a0.
      intros.
      case (Z_le_lt_eq_dec 0 na H1).
      intro.
      apply False_ind.
      elim H2.
      intros.
      apply Z.lt_irrefl with 0%Z.
      apply Z.lt_le_trans with (na + nb)%Z.
      rewrite Zplus_0_r_reverse with 0%Z.
      apply Zplus_lt_le_compat.
      assumption.
      assumption.
      apply (Zsgn_14 _ z).
      intro.
      rewrite <- e.
      simpl in |- *.
      apply Z.le_refl.
      intro.
      elim a0.
      intros.
      apply Zle_neg_opp.
      assumption.
      intro.
      discriminate e.
      generalize (sg_pos_2 a b c d p H_hsign na nb nc nd (nR p0) H).
      intro.
      case H0.
      intro.
      case s.
      intro.
      elim a0.
      intros.
      elim H2.
      intros.
      case (Z_le_lt_eq_dec 0 nb H3).
      intro.
      apply False_ind.
      apply Z.lt_irrefl with 0%Z.
      apply Z.lt_le_trans with (na + nb)%Z.
      rewrite Zplus_0_r_reverse with 0%Z.
      apply Zplus_le_lt_compat.
      assumption.
      assumption.
      apply (Zsgn_14 _ z).
      intro.
      rewrite <- e.
      simpl in |- *.
      apply Z.le_refl.
      intro.
      elim a0.
      intros.
      elim H2.
      intros.
      apply Zle_neg_opp.
      assumption.
      intro.
      discriminate e.
      generalize (sg_pos_2 a b c d p H_hsign na nb nc nd (nR p0) H).
      intro.
      case H0.
      intro.
      case s.
      intro.
      elim a0.
      intros.
      elim H2.
      intros.
      elim H4.
      intros.
      case (Z_le_lt_eq_dec 0 nc H5).
      intro.
      apply False_ind.
      apply Z.lt_irrefl with 0%Z.
      apply Z.lt_le_trans with (nc + nd)%Z.
      rewrite Zplus_0_r_reverse with 0%Z.
      apply Zplus_lt_le_compat.
      assumption.
      assumption.
      case (sg_pos_1 a b c d p H_hsign na nb nc nd (nR p0) H).
      intro.
      apply False_ind.
      elim a1.
      intros.
      apply Z.lt_irrefl with 0%Z.
      apply Z.lt_le_trans with (na + nb)%Z.
      assumption.
      apply (Zsgn_14 _ z).
      intros.
      elim a1.
      intros.
      apply Zlt_le_weak.
      assumption.
      intro.
      rewrite <- e.
      simpl in |- *.
      apply Z.le_refl.
      intro.
      elim a0.
      intros.
      elim H2.
      intros.
      elim H4.
      intros.
      apply Zle_neg_opp.
      assumption.
      intro.
      discriminate e.
      generalize (sg_pos_2 a b c d p H_hsign na nb nc nd (nR p0) H).
      intro.
      case H0.
      intro.
      case s.
      intro.
      elim a0.
      intros.
      elim H2.
      intros.
      elim H4.
      intros.
      case (Z_le_lt_eq_dec 0 nd H6).
      intro.
      apply False_ind.
      apply Z.lt_irrefl with 0%Z.
      apply Z.lt_le_trans with (nc + nd)%Z.
      rewrite Zplus_0_r_reverse with 0%Z.
      apply Zplus_le_lt_compat.
      assumption.
      assumption.
      case (sg_pos_1 a b c d p H_hsign na nb nc nd (nR p0) H).
      intro.
      apply False_ind.
      elim a1.
      intros.
      apply Z.lt_irrefl with 0%Z.
      apply Z.lt_le_trans with (na + nb)%Z.
      assumption.
      apply (Zsgn_14 _ z).
      intros.
      elim a1.
      intros.
      apply Zlt_le_weak.
      assumption.
      intro.
      rewrite <- e.
      simpl in |- *.
      apply Z.le_refl.
      intro.
      elim a0.
      intros.
      elim H2.
      intros.
      elim H4.
      intros.
      apply Zle_neg_opp.
      assumption.
      intro.
      discriminate e.
      (* l3 = (dL p0) *)
      apply homographicAcc_wf.
      generalize (sg_pos_1 a b c d p H_hsign na nb nc nd (dL p0) H).
      intro.
      case H0.
      intros.
      apply False_ind.
      elim a0.
      intros.
      generalize (Zsgn_14 _ z).
      intro.
      apply Z.lt_irrefl with 0%Z.
      apply Z.lt_le_trans with (na + nb)%Z.
      assumption.
      assumption.
      intro.
      elim a0.
      intros.
      rewrite <- Zopp_plus_distr.
      apply Zlt_neg_opp.
      assumption.
      generalize (sg_pos_1 a b c d p H_hsign na nb nc nd (dL p0) H).
      intro.
      case H0.
      intros.
      apply False_ind.
      elim a0.
      intros.
      generalize (Zsgn_14 _ z).
      intro.
      apply Z.lt_irrefl with 0%Z.
      apply Z.lt_le_trans with (na + nb)%Z.
      assumption.
      assumption.
      intro.
      elim a0.
      intros.
      rewrite <- Zopp_plus_distr.
      apply Zlt_neg_opp.
      assumption.
      generalize (sg_pos_2 a b c d p H_hsign na nb nc nd (dL p0) H).
      intro.
      case H0.
      intro.
      case s.
      intro.
      elim a0.
      intros.
      case (Z_le_lt_eq_dec 0 na H1).
      intro.
      apply False_ind.
      elim H2.
      intros.
      apply Z.lt_irrefl with 0%Z.
      apply Z.lt_le_trans with (na + nb)%Z.
      rewrite Zplus_0_r_reverse with 0%Z.
      apply Zplus_lt_le_compat.
      assumption.
      assumption.
      apply (Zsgn_14 _ z).
      intro.
      rewrite <- e.
      simpl in |- *.
      apply Z.le_refl.
      intro.
      elim a0.
      intros.
      apply Zle_neg_opp.
      assumption.
      intro.
      discriminate e.
      generalize (sg_pos_2 a b c d p H_hsign na nb nc nd (dL p0) H).
      intro.
      case H0.
      intro.
      case s.
      intro.
      elim a0.
      intros.
      elim H2.
      intros.
      case (Z_le_lt_eq_dec 0 nb H3).
      intro.
      apply False_ind.
      apply Z.lt_irrefl with 0%Z.
      apply Z.lt_le_trans with (na + nb)%Z.
      rewrite Zplus_0_r_reverse with 0%Z.
      apply Zplus_le_lt_compat.
      assumption.
      assumption.
      apply (Zsgn_14 _ z).
      intro.
      rewrite <- e.
      simpl in |- *.
      apply Z.le_refl.
      intro.
      elim a0.
      intros.
      elim H2.
      intros.
      apply Zle_neg_opp.
      assumption.
      intro.
      discriminate e.
      generalize (sg_pos_2 a b c d p H_hsign na nb nc nd (dL p0) H).
      intro.
      case H0.
      intro.
      case s.
      intro.
      elim a0.
      intros.
      elim H2.
      intros.
      elim H4.
      intros.
      case (Z_le_lt_eq_dec 0 nc H5).
      intro.
      apply False_ind.
      apply Z.lt_irrefl with 0%Z.
      apply Z.lt_le_trans with (nc + nd)%Z.
      rewrite Zplus_0_r_reverse with 0%Z.
      apply Zplus_lt_le_compat.
      assumption.
      assumption.
      case (sg_pos_1 a b c d p H_hsign na nb nc nd (dL p0) H).
      intro.
      apply False_ind.
      elim a1.
      intros.
      apply Z.lt_irrefl with 0%Z.
      apply Z.lt_le_trans with (na + nb)%Z.
      assumption.
      apply (Zsgn_14 _ z).
      intros.
      elim a1.
      intros.
      apply Zlt_le_weak.
      assumption.
      intro.
      rewrite <- e.
      simpl in |- *.
      apply Z.le_refl.
      intro.
      elim a0.
      intros.
      elim H2.
      intros.
      elim H4.
      intros.
      apply Zle_neg_opp.
      assumption.
      intro.
      discriminate e.
      generalize (sg_pos_2 a b c d p H_hsign na nb nc nd (dL p0) H).
      intro.
      case H0.
      intro.
      case s.
      intro.
      elim a0.
      intros.
      elim H2.
      intros.
      elim H4.
      intros.
      case (Z_le_lt_eq_dec 0 nd H6).
      intro.
      apply False_ind.
      apply Z.lt_irrefl with 0%Z.
      apply Z.lt_le_trans with (nc + nd)%Z.
      rewrite Zplus_0_r_reverse with 0%Z.
      apply Zplus_le_lt_compat.
      assumption.
      assumption.
      case (sg_pos_1 a b c d p H_hsign na nb nc nd (dL p0) H).
      intro.
      apply False_ind.
      elim a1.
      intros.
      apply Z.lt_irrefl with 0%Z.
      apply Z.lt_le_trans with (na + nb)%Z.
      assumption.
      apply (Zsgn_14 _ z).
      intros.
      elim a1.
      intros.
      apply Zlt_le_weak.
      assumption.
      intro.
      rewrite <- e.
      simpl in |- *.
      apply Z.le_refl.
      intro.
      elim a0.
      intros.
      elim H2.
      intros.
      elim H4.
      intros.
      apply Zle_neg_opp.
      assumption.
      intro.
      discriminate e.
      (* l3 = One *)
      apply homographicacc0.
      reflexivity.
      generalize (sg_pos_1 a b c d p H_hsign na nb nc nd One H).
      intro.
      case H0.
      intros.
      apply False_ind.
      elim a0.
      intros.
      generalize (Zsgn_14 _ z).
      intro.
      apply Z.lt_irrefl with 0%Z.
      apply Z.lt_le_trans with (na + nb)%Z.
      assumption.
      assumption.
      intro.
      elim a0.
      intros.
      rewrite <- Zopp_plus_distr.
      apply Zlt_neg_opp.
      assumption.
      generalize (sg_pos_1 a b c d p H_hsign na nb nc nd One H).
      intro.
      case H0.
      intros.
      apply False_ind.
      elim a0.
      intros.
      generalize (Zsgn_14 _ z).
      intro.
      apply Z.lt_irrefl with 0%Z.
      apply Z.lt_le_trans with (na + nb)%Z.
      assumption.
      assumption.
      intro.
      elim a0.
      intros.
      rewrite <- Zopp_plus_distr.
      apply Zlt_neg_opp.
      assumption.
Defined.

Lemma Qhomographic_Qpositive_to_Q_homographicAcc_neg_1 :
 forall (a b c d : Z) (p : Qpositive)
   (H_hsign : Qhomographic_sg_denom_nonzero c d p),
 (a * d)%Z <> (b * c)%Z ->
 h_sign a b c d p H_hsign = (-1)%Z ->
 (Z.sgn (new_a a b c d p H_hsign + new_b a b c d p H_hsign) < 0)%Z ->
 homographicAcc (- new_a a b c d p H_hsign) (- new_b a b c d p H_hsign)
   (new_c a b c d p H_hsign) (new_d a b c d p H_hsign)
   (new_p a b c d p H_hsign).
Proof.
 intros a b c d p H_hsign ad_neq_bc l1_eq__minus_one z.
 set (na := new_a a b c d p H_hsign) in *.
 set (nb := new_b a b c d p H_hsign) in *.
 set (nc := new_c a b c d p H_hsign) in *.
 set (nd := new_d a b c d p H_hsign) in *.
 set (l3 := new_p a b c d p H_hsign) in *.
 assert
  (H :
   Qhomographic_sign a b c d p H_hsign = ((-1)%Z, (na, (nb, (nc, nd)), l3))).
 unfold na, nb, nc, nd, l3 in |- *.
 rewrite <- l1_eq__minus_one.
 unfold new_a, new_b, new_c, new_d, new_p in |- *.
 replace (h_sign a b c d p H_hsign) with
  (fst (Qhomographic_sign a b c d p H_hsign)); [ idtac | reflexivity ];
  repeat rewrite <- pair_1; reflexivity.
      destruct l3 as [p0| p0| ].
      (* l3 = (nR p0) *)
      apply homographicAcc_wf.
      rewrite <- Zopp_plus_distr.
      apply Zlt_neg_opp.
      apply Zsgn_11.
      assumption.

      generalize (sg_neg_1 a b c d p H_hsign na nb nc nd (nR p0) H).
      intros.
      case H0.
      intro.
      elim a0.
      intros.
      apply False_ind.
      generalize (Zsgn_11 (na + nb) z).
      intro.
      apply Z.lt_irrefl with 0%Z.
      apply Z.lt_trans with (na + nb)%Z.
      assumption.
      assumption.
      intros.
      elim a0.
      intros.
      assumption.
      generalize (sg_neg_2 a b c d p H_hsign na nb nc nd (nR p0) H).
      intro.
      case H0.
      intro.
      case s.
      intro.
      apply False_ind.
      elim a0.
      intros.
      elim H2.
      intros.
      apply Z.lt_irrefl with 0%Z.
      apply Z.le_lt_trans with (na + nb)%Z.
      rewrite Zplus_0_r_reverse with 0%Z.
      apply Zplus_le_compat.
      assumption.
      assumption.
      apply Zsgn_11.
      assumption.
      intro.
      elim a0.
      intros.
      apply Zle_neg_opp.
      assumption.
      intro.
      discriminate e.
      generalize (sg_neg_2 a b c d p H_hsign na nb nc nd (nR p0) H).
      intro.
      case H0.
      intro.
      case s.
      intro.
      elim a0.
      intros.
      elim H2.
      intros.
      apply False_ind.
      apply Z.lt_irrefl with 0%Z.
      apply Z.le_lt_trans with (na + nb)%Z.
      rewrite Zplus_0_r_reverse with 0%Z.
      apply Zplus_le_compat.
      assumption.
      assumption.
      apply Zsgn_11.
      assumption.
      intros.
      elim a0.
      intros.
      elim H2.
      intros.
      apply Zle_neg_opp.
      assumption.
      intro.
      discriminate e.
      generalize (sg_neg_2 a b c d p H_hsign na nb nc nd (nR p0) H).
      intro.
      case H0.
      intro.
      case s.
      intro.
      elim a0.
      intros.
      elim H2.
      intros.
      apply False_ind.
      apply Z.lt_irrefl with 0%Z.
      apply Z.le_lt_trans with (na + nb)%Z.
      rewrite Zplus_0_r_reverse with 0%Z.
      apply Zplus_le_compat.
      assumption.
      assumption.
      apply Zsgn_11.
      assumption.
      intros.
      elim a0.
      intros.
      elim H2.
      intros.
      elim H4.
      intros.
      assumption.
      intro.
      discriminate e.
      generalize (sg_neg_2 a b c d p H_hsign na nb nc nd (nR p0) H).
      intro.
      case H0.
      intro.
      case s.
      intro.
      elim a0.
      intros.
      elim H2.
      intros.
      apply False_ind.
      apply Z.lt_irrefl with 0%Z.
      apply Z.le_lt_trans with (na + nb)%Z.
      rewrite Zplus_0_r_reverse with 0%Z.
      apply Zplus_le_compat.
      assumption.
      assumption.
      apply Zsgn_11.
      assumption.
      intro.
      elim a0.
      intros.
      elim H2.
      intros.
      elim H4.
      intros.
      assumption.
      intro.
      discriminate e.
      (* l3 = (dL p0) *)
      apply homographicAcc_wf.
      rewrite <- Zopp_plus_distr.
      apply Zlt_neg_opp.
      apply Zsgn_11.
      assumption.

      generalize (sg_neg_1 a b c d p H_hsign na nb nc nd (dL p0) H).
      intros.
      case H0.
      intro.
      elim a0.
      intros.
      apply False_ind.
      generalize (Zsgn_11 (na + nb) z).
      intro.
      apply Z.lt_irrefl with 0%Z.
      apply Z.lt_trans with (na + nb)%Z.
      assumption.
      assumption.
      intros.
      elim a0.
      intros.
      assumption.
      generalize (sg_neg_2 a b c d p H_hsign na nb nc nd (dL p0) H).
      intro.
      case H0.
      intro.
      case s.
      intro.
      apply False_ind.
      elim a0.
      intros.
      elim H2.
      intros.
      apply Z.lt_irrefl with 0%Z.
      apply Z.le_lt_trans with (na + nb)%Z.
      rewrite Zplus_0_r_reverse with 0%Z.
      apply Zplus_le_compat.
      assumption.
      assumption.
      apply Zsgn_11.
      assumption.
      intro.
      elim a0.
      intros.
      apply Zle_neg_opp.
      assumption.
      intro.
      discriminate e.
      generalize (sg_neg_2 a b c d p H_hsign na nb nc nd (dL p0) H).
      intro.
      case H0.
      intro.
      case s.
      intro.
      elim a0.
      intros.
      elim H2.
      intros.
      apply False_ind.
      apply Z.lt_irrefl with 0%Z.
      apply Z.le_lt_trans with (na + nb)%Z.
      rewrite Zplus_0_r_reverse with 0%Z.
      apply Zplus_le_compat.
      assumption.
      assumption.
      apply Zsgn_11.
      assumption.
      intros.
      elim a0.
      intros.
      elim H2.
      intros.
      apply Zle_neg_opp.
      assumption.
      intro.
      discriminate e.
      generalize (sg_neg_2 a b c d p H_hsign na nb nc nd (dL p0) H).
      intro.
      case H0.
      intro.
      case s.
      intro.
      elim a0.
      intros.
      elim H2.
      intros.
      apply False_ind.
      apply Z.lt_irrefl with 0%Z.
      apply Z.le_lt_trans with (na + nb)%Z.
      rewrite Zplus_0_r_reverse with 0%Z.
      apply Zplus_le_compat.
      assumption.
      assumption.
      apply Zsgn_11.
      assumption.
      intros.
      elim a0.
      intros.
      elim H2.
      intros.
      elim H4.
      intros.
      assumption.
      intro.
      discriminate e.
      generalize (sg_neg_2 a b c d p H_hsign na nb nc nd (dL p0) H).
      intro.
      case H0.
      intro.
      case s.
      intro.
      elim a0.
      intros.
      elim H2.
      intros.
      apply False_ind.
      apply Z.lt_irrefl with 0%Z.
      apply Z.le_lt_trans with (na + nb)%Z.
      rewrite Zplus_0_r_reverse with 0%Z.
      apply Zplus_le_compat.
      assumption.
      assumption.
      apply Zsgn_11.
      assumption.
      intro.
      elim a0.
      intros.
      elim H2.
      intros.
      elim H4.
      intros.
      assumption.
      intro.
      discriminate e.
      (* l3 = One *)
      apply homographicacc0.
      reflexivity.
      rewrite <- Zopp_plus_distr.
      apply Zlt_neg_opp.
      apply Zsgn_11.
      assumption.
      generalize (sg_neg_1 a b c d p H_hsign na nb nc nd One H).
      intros.
      case H0.
      intro.
      elim a0.
      intros.
      apply False_ind.
      generalize (Zsgn_11 (na + nb) z).
      intro.
      apply Z.lt_irrefl with 0%Z.
      apply Z.lt_trans with (na + nb)%Z.
      assumption.
      assumption.
      intro.
      elim a0.
      intros.
      assumption.
Defined.

Lemma Qhomographic_Qpositive_to_Q_homographicAcc_neg_2 :
 forall (a b c d : Z) (p : Qpositive)
   (H_hsign : Qhomographic_sg_denom_nonzero c d p),
 (a * d)%Z <> (b * c)%Z ->
 h_sign a b c d p H_hsign = (-1)%Z ->
 (0 <= Z.sgn (new_a a b c d p H_hsign + new_b a b c d p H_hsign))%Z ->
 homographicAcc (new_a a b c d p H_hsign) (new_b a b c d p H_hsign)
   (- new_c a b c d p H_hsign) (- new_d a b c d p H_hsign)
   (new_p a b c d p H_hsign).
Proof.
 intros a b c d p H_hsign ad_neq_bc l1_eq__minus_one z.
 set (na := new_a a b c d p H_hsign) in *.
 set (nb := new_b a b c d p H_hsign) in *.
 set (nc := new_c a b c d p H_hsign) in *.
 set (nd := new_d a b c d p H_hsign) in *.
 set (l3 := new_p a b c d p H_hsign) in *.
 assert
  (H :
   Qhomographic_sign a b c d p H_hsign = ((-1)%Z, (na, (nb, (nc, nd)), l3))).
 unfold na, nb, nc, nd, l3 in |- *.
 rewrite <- l1_eq__minus_one.
 unfold new_a, new_b, new_c, new_d, new_p in |- *.
 replace (h_sign a b c d p H_hsign) with
  (fst (Qhomographic_sign a b c d p H_hsign)); [ idtac | reflexivity ];
  repeat rewrite <- pair_1; reflexivity.
      destruct l3 as [p0| p0| ].
      (* l3 = (nR p0) *)
      apply homographicAcc_wf.
      generalize (sg_neg_1 a b c d p H_hsign na nb nc nd (nR p0) H).
      intro.
      case H0.
      intros.
      elim a0.
      intros.
      assumption.
      intros.
      apply False_ind.
      elim a0.
      intros.
      generalize (Zsgn_13 _ z).
      intro.
      apply Z.lt_irrefl with 0%Z.
      apply Z.le_lt_trans with (na + nb)%Z.
      assumption.
      assumption.
      generalize (sg_neg_1 a b c d p H_hsign na nb nc nd (nR p0) H).
      intro.
      case H0.
      intros.
      elim a0.
      intros.
      rewrite <- Zopp_plus_distr.
      apply Zlt_neg_opp.
      assumption.
      intros.
      apply False_ind.
      elim a0.
      intros.
      generalize (Zsgn_13 _ z).
      intro.
      apply Z.lt_irrefl with 0%Z.
      apply Z.le_lt_trans with (na + nb)%Z.
      assumption.
      assumption.
      generalize (sg_neg_2 a b c d p H_hsign na nb nc nd (nR p0) H).
      intro.
      case H0.
      intro.
      case s.
      intro.
      elim a0.
      intros.
      assumption.
      intros.
      elim a0.
      intros.
      case (Z_le_lt_eq_dec na 0 H1).
      intro.
      apply False_ind.
      elim H2.
      intros.
      apply Z.lt_irrefl with 0%Z.
      apply Z.le_lt_trans with (na + nb)%Z.
      apply (Zsgn_13 _ z).
      rewrite Zplus_0_r_reverse with 0%Z.
      apply Zplus_lt_le_compat.
      assumption.
      assumption.
      intro.
      rewrite e.
      apply Z.le_refl.
      intro.
      discriminate e.
      generalize (sg_neg_2 a b c d p H_hsign na nb nc nd (nR p0) H).
      intro.
      case H0.
      intro.
      case s.
      intro.
      elim a0.
      intros.
      elim H2.
      intros.
      assumption.
      intros.
      elim a0.
      intros.
      elim H2.
      intros.
      case (Z_le_lt_eq_dec nb 0 H3).
      intro.
      apply False_ind.
      apply Z.lt_irrefl with 0%Z.
      apply Z.le_lt_trans with (na + nb)%Z.
      apply (Zsgn_13 _ z).
      rewrite Zplus_0_r_reverse with 0%Z.
      apply Zplus_le_lt_compat.
      assumption.
      assumption.
      intro.
      rewrite e.
      apply Z.le_refl.
      intro.
      discriminate e.
      generalize (sg_neg_2 a b c d p H_hsign na nb nc nd (nR p0) H).
      intro.
      case H0.
      intro.
      case s.
      intro.
      elim a0.
      intros.
      elim H2.
      intros.
      elim H4.
      intros.
      apply Zle_neg_opp.
      assumption.
      intro.
      elim a0.
      intros.
      elim H2.
      intros.
      elim H4.
      intros.
      case (Z_le_lt_eq_dec 0 nc H5).
      intro.
      apply False_ind.
      apply Z.lt_irrefl with 0%Z.
      apply Z.lt_trans with (nc + nd)%Z.
      rewrite Zplus_0_r_reverse with 0%Z.
      apply Zplus_lt_le_compat.
      assumption.
      assumption.
      case (sg_neg_1 a b c d p H_hsign na nb nc nd (nR p0) H).
      intro.
      elim a1.
      intros.
      assumption.
      intro.
      apply False_ind.
      apply Z.lt_irrefl with 0%Z.
      apply Z.le_lt_trans with (na + nb)%Z.
      apply (Zsgn_13 _ z).
      elim a1.
      intros.
      assumption.
      intro.
      rewrite <- e.
      simpl in |- *.
      apply Z.le_refl.
      intro.
      discriminate e.
      generalize (sg_neg_2 a b c d p H_hsign na nb nc nd (nR p0) H).
      intro.
      case H0.
      intro.
      case s.
      intro.
      elim a0.
      intros.
      elim H2.
      intros.
      elim H4.
      intros.
      apply Zle_neg_opp.
      assumption.
      intro.
      elim a0.
      intros.
      elim H2.
      intros.
      elim H4.
      intros.
      case (Z_le_lt_eq_dec 0 nd H6).
      intro.
      apply False_ind.
      apply Z.lt_irrefl with 0%Z.
      apply Z.lt_trans with (nc + nd)%Z.
      rewrite Zplus_0_r_reverse with 0%Z.
      apply Zplus_le_lt_compat.
      assumption.
      assumption.
      case (sg_neg_1 a b c d p H_hsign na nb nc nd (nR p0) H).
      intro.
      elim a1.
      intros.
      assumption.
      intro.
      apply False_ind.
      apply Z.lt_irrefl with 0%Z.
      apply Z.le_lt_trans with (na + nb)%Z.
      apply (Zsgn_13 _ z).
      elim a1.
      intros.
      assumption.
      intro.
      rewrite <- e.
      simpl in |- *.
      apply Z.le_refl.
      intro.
      discriminate e.
      (* l3 = (dL p0) *)
      apply homographicAcc_wf.
      generalize (sg_neg_1 a b c d p H_hsign na nb nc nd (dL p0) H).
      intro.
      case H0.
      intros.
      elim a0.
      intros.
      assumption.
      intros.
      apply False_ind.
      elim a0.
      intros.
      generalize (Zsgn_13 _ z).
      intro.
      apply Z.lt_irrefl with 0%Z.
      apply Z.le_lt_trans with (na + nb)%Z.
      assumption.
      assumption.
      generalize (sg_neg_1 a b c d p H_hsign na nb nc nd (dL p0) H).
      intro.
      case H0.
      intros.
      elim a0.
      intros.
      rewrite <- Zopp_plus_distr.
      apply Zlt_neg_opp.
      assumption.
      intros.
      apply False_ind.
      elim a0.
      intros.
      generalize (Zsgn_13 _ z).
      intro.
      apply Z.lt_irrefl with 0%Z.
      apply Z.le_lt_trans with (na + nb)%Z.
      assumption.
      assumption.
      generalize (sg_neg_2 a b c d p H_hsign na nb nc nd (dL p0) H).
      intro.
      case H0.
      intro.
      case s.
      intro.
      elim a0.
      intros.
      assumption.
      intros.
      elim a0.
      intros.
      case (Z_le_lt_eq_dec na 0 H1).
      intro.
      apply False_ind.
      elim H2.
      intros.
      apply Z.lt_irrefl with 0%Z.
      apply Z.le_lt_trans with (na + nb)%Z.
      apply (Zsgn_13 _ z).
      rewrite Zplus_0_r_reverse with 0%Z.
      apply Zplus_lt_le_compat.
      assumption.
      assumption.
      intro.
      rewrite e.
      apply Z.le_refl.
      intro.
      discriminate e.
      generalize (sg_neg_2 a b c d p H_hsign na nb nc nd (dL p0) H).
      intro.
      case H0.
      intro.
      case s.
      intro.
      elim a0.
      intros.
      elim H2.
      intros.
      assumption.
      intros.
      elim a0.
      intros.
      elim H2.
      intros.
      case (Z_le_lt_eq_dec nb 0 H3).
      intro.
      apply False_ind.
      apply Z.lt_irrefl with 0%Z.
      apply Z.le_lt_trans with (na + nb)%Z.
      apply (Zsgn_13 _ z).
      rewrite Zplus_0_r_reverse with 0%Z.
      apply Zplus_le_lt_compat.
      assumption.
      assumption.
      intro.
      rewrite e.
      apply Z.le_refl.
      intro.
      discriminate e.
      generalize (sg_neg_2 a b c d p H_hsign na nb nc nd (dL p0) H).
      intro.
      case H0.
      intro.
      case s.
      intro.
      elim a0.
      intros.
      elim H2.
      intros.
      elim H4.
      intros.
      apply Zle_neg_opp.
      assumption.
      intro.
      elim a0.
      intros.
      elim H2.
      intros.
      elim H4.
      intros.
      case (Z_le_lt_eq_dec 0 nc H5).
      intro.
      apply False_ind.
      apply Z.lt_irrefl with 0%Z.
      apply Z.lt_trans with (nc + nd)%Z.
      rewrite Zplus_0_r_reverse with 0%Z.
      apply Zplus_lt_le_compat.
      assumption.
      assumption.
      case (sg_neg_1 a b c d p H_hsign na nb nc nd (dL p0) H).
      intro.
      elim a1.
      intros.
      assumption.
      intro.
      apply False_ind.
      apply Z.lt_irrefl with 0%Z.
      apply Z.le_lt_trans with (na + nb)%Z.
      apply (Zsgn_13 _ z).
      elim a1.
      intros.
      assumption.
      intro.
      rewrite <- e.
      simpl in |- *.
      apply Z.le_refl.
      intro.
      discriminate e.
      generalize (sg_neg_2 a b c d p H_hsign na nb nc nd (dL p0) H).
      intro.
      case H0.
      intro.
      case s.
      intro.
      elim a0.
      intros.
      elim H2.
      intros.
      elim H4.
      intros.
      apply Zle_neg_opp.
      assumption.
      intro.
      elim a0.
      intros.
      elim H2.
      intros.
      elim H4.
      intros.
      case (Z_le_lt_eq_dec 0 nd H6).
      intro.
      apply False_ind.
      apply Z.lt_irrefl with 0%Z.
      apply Z.lt_trans with (nc + nd)%Z.
      rewrite Zplus_0_r_reverse with 0%Z.
      apply Zplus_le_lt_compat.
      assumption.
      assumption.
      case (sg_neg_1 a b c d p H_hsign na nb nc nd (dL p0) H).
      intro.
      elim a1.
      intros.
      assumption.
      intro.
      apply False_ind.
      apply Z.lt_irrefl with 0%Z.
      apply Z.le_lt_trans with (na + nb)%Z.
      apply (Zsgn_13 _ z).
      elim a1.
      intros.
      assumption.
      intro.
      rewrite <- e.
      simpl in |- *.
      apply Z.le_refl.
      intro.
      discriminate e.
      (* l3 = One *)
      apply homographicacc0.
      reflexivity.
      generalize (sg_neg_1 a b c d p H_hsign na nb nc nd One H).
      intro.
      case H0.
      intros.
      elim a0.
      intros.
      assumption.
      intro.
      apply False_ind.
      elim a0.
      intros.
      generalize (Zsgn_13 _ z).
      intro.
      apply Z.lt_irrefl with 0%Z.
      apply Z.le_lt_trans with (na + nb)%Z.
      assumption.
      assumption.
      rewrite <- Zopp_plus_distr.
      apply Zlt_neg_opp.
      generalize (sg_neg_1 a b c d p H_hsign na nb nc nd One H).
      intro.
      case H0.
      intros.
      elim a0.
      intros.
      assumption.
      intro.
      apply False_ind.
      elim a0.
      intros.
      generalize (Zsgn_13 _ z).
      intro.
      apply Z.lt_irrefl with 0%Z.
      apply Z.le_lt_trans with (na + nb)%Z.
      assumption.
      assumption.
Defined.


From sflib Require Import sflib.
Require Import Coq.Classes.RelationClasses.
From Fairness Require Import Axioms NatStructsLarge.
From Fairness Require Import PCMLarge World.
From Fairness Require Import Mod.
Require Import String Lia Program.

Set Implicit Arguments.

Section THREADS_RA_DEF.

  Inductive threadsRA_car : Type :=
  | global_local
      (ths_ctx ths_usr : TIdSet.t)
      (ths_ctx' ths_usr' : TIdSet.t)
  | local (ths_ctx' ths_usr' : TIdSet.t)
  | boom
  .

  Inductive threadsRA_wf : threadsRA_car -> Prop :=
  | wf_global_local ths_ctx ths_usr ths_ctx' ths_usr'
      (DISJOINT : NatMapP.Disjoint ths_ctx ths_usr)
      (LE_CTX : KeySetLE ths_ctx' ths_ctx)
      (LE_USR : KeySetLE ths_usr' ths_usr)
    : threadsRA_wf (global_local ths_ctx ths_usr ths_ctx' ths_usr')
  | wf_local ths_ctx' ths_usr'
    : threadsRA_wf (local ths_ctx' ths_usr')
  .

  Definition add (r1 r2 : threadsRA_car) : threadsRA_car :=
    match r1, r2 with
    | global_local ths_ctx ths_usr ths_ctx' ths_usr', global_local _ _ _ _      => boom
    | global_local ths_ctx ths_usr ths_ctx' ths_usr', local ths_ctx'' ths_usr'' =>
        if (disjoint ths_ctx' ths_ctx'' && disjoint ths_usr' ths_usr'')%bool
        then global_local ths_ctx ths_usr (NatMapP.update ths_ctx' ths_ctx'') (NatMapP.update ths_usr' ths_usr'')
        else boom
    | global_local ths_ctx ths_usr ths_ctx' ths_usr', boom                      => boom
    | local ths_ctx' ths_usr', global_local ths_ctx ths_usr ths_ctx'' ths_usr'' =>
        if (disjoint ths_ctx' ths_ctx'' && disjoint ths_usr' ths_usr'')%bool
        then global_local ths_ctx ths_usr (NatMapP.update ths_ctx' ths_ctx'') (NatMapP.update ths_usr' ths_usr'')
        else boom
    | local ths_ctx' ths_usr', local ths_ctx'' ths_usr''                        =>
        if (disjoint ths_ctx' ths_ctx'' && disjoint ths_usr' ths_usr'')%bool
        then local (NatMapP.update ths_ctx' ths_ctx'') (NatMapP.update ths_usr' ths_usr'')
        else boom
    | local ths_ctx' ths_usr', boom                                             => boom
    | boom, _                                                                   => boom
    end.
  Program Instance threadsRA: URA.t :=
    {|
      URA.car := threadsRA_car;
      URA.unit := local NatSet.empty NatSet.empty;
      URA._wf := threadsRA_wf;
      URA._add := add;
      URA.core := fun _ => local NatSet.empty NatSet.empty;
    |}.
  Next Obligation.
    destruct a, b; ss.
    all: rewrite disjoint_comm with (x := ths_ctx').
    all: rewrite disjoint_comm with (x := ths_usr').
    all: rewrite union_comm with (x := ths_ctx').
    all: rewrite union_comm with (x := ths_usr').
    all: ss.
  Qed.
  Next Obligation.
    destruct a, b, c; try (ss; des_ifs; fail).
    all: unfold add; des_ifs; try (rewrite 2 union_assoc; ss); solve_disjoint!.
  Qed.
  Next Obligation.
    unseal "ra". destruct a; try easy.
    all:
      unfold add; des_ifs; try (do 2 rewrite union_comm, union_empty; ss);
      unfold NatSet.empty in Heq; solve_disjoint!.
  Qed.
  Next Obligation.
    unseal "ra". econs.
  Qed.
  Next Obligation.
    unseal "ra". destruct a, b; inv H; unfold add; des_ifs; econs; ss.
    - assert (KeySetLE ths_ctx' (NatMapP.update ths_ctx' ths_ctx'0)) by eapply union_KeySetLE.
      unfold KeySetLE in *. auto.
    - assert (KeySetLE ths_usr' (NatMapP.update ths_usr' ths_usr'0)) by eapply union_KeySetLE.
      unfold KeySetLE in *. auto.
  Qed.
  Next Obligation.
    unseal "ra". destruct a; ss.
    - f_equal; rewrite union_comm; ss.
    - f_equal; rewrite union_comm; ss.
  Qed.
  Next Obligation.
    exists (local NatSet.empty NatSet.empty). unseal "ra". ss.
  Qed.

End THREADS_RA_DEF.

Section THREADS_RA.

  Definition global_th (ths_ctx ths_usr : TIdSet.t) : threadsRA := global_local ths_ctx ths_usr TIdSet.empty TIdSet.empty.

  Definition local_th_context (tid: thread_id): threadsRA := local (TIdSet.add tid TIdSet.empty) TIdSet.empty.

  Definition local_th_user (tid: thread_id): threadsRA := local TIdSet.empty (TIdSet.add tid TIdSet.empty).

  Lemma local_th_context_in_context ths_ctx ths_usr tid r_ctx
        (VALID: URA.wf (global_th ths_ctx ths_usr ⋅ local_th_context tid ⋅ r_ctx))
    :
    TIdSet.In tid ths_ctx.
  Proof.
    eapply URA.wf_mon in VALID. unfold URA.add, URA.wf in VALID. unseal "ra".
    unfold global_th, local_th_context in *. ss.
    inv VALID. eapply LE_CTX. (do 3 econs); ss.
  Qed.

  Lemma local_th_user_in_user ths_ctx ths_usr tid r_ctx
        (VALID: URA.wf (global_th ths_ctx ths_usr ⋅ local_th_user tid ⋅ r_ctx))
    :
    TIdSet.In tid ths_usr.
    eapply URA.wf_mon in VALID. unfold URA.add, URA.wf in VALID. unseal "ra".
    inv VALID. eapply LE_USR. (do 3 econs); ss.
  Qed.

  Lemma initial_global_th_valid
    :
    URA.wf (global_th TIdSet.empty TIdSet.empty).
  Proof.
    unfold URA.wf. unseal "ra". econs; eauto using Disjoint_empty, KeySetLE_empty.
  Qed.

  Lemma global_th_alloc_context ths_ctx0 ths_usr r_ctx
        tid ths_ctx1
        (VALID: URA.wf (global_th ths_ctx0 ths_usr ⋅ r_ctx))
        (ADD: TIdSet.add_new tid ths_ctx0 ths_ctx1)
        (NONE: ~ TIdSet.In tid ths_usr)
    :
    URA.wf (global_th ths_ctx1 ths_usr ⋅ local_th_context tid ⋅ r_ctx).
  Proof.
    unfold URA.wf, URA.add in *. unseal "ra". destruct r_ctx; ss.
    rewrite ! union_empty in *. unfold union, NatMap.fold; ss. inv VALID. inv ADD. des_ifs.
    - econs; ss.
      + ii. des. eapply NatMapP.F.add_in_iff in H. des.
        * subst. eauto.
        * eapply DISJOINT. eauto.
      + ii. eapply NatMapP.F.add_in_iff. rewrite union_comm in H. eapply NatMapP.F.add_in_iff in H. des; eauto.
    - eapply NatMapP.F.not_find_in_iff in NEW. solve_andb.
      + eapply disjoint_false_iff' in H. des.
        eapply NatMapP.F.add_in_iff in H. rewrite NatMapP.F.empty_in_iff in H.
        des; ss; subst. firstorder.
      + unfold TIdSet.empty in H. solve_disjoint.
  Qed.

  Lemma global_th_alloc_user ths_ctx ths_usr0 r_ctx
        tid ths_usr1
        (VALID: URA.wf (global_th ths_ctx ths_usr0 ⋅ r_ctx))
        (ADD: TIdSet.add_new tid ths_usr0 ths_usr1)
        (NONE: ~ TIdSet.In tid ths_ctx)
    :
    URA.wf (global_th ths_ctx ths_usr1 ⋅ local_th_user tid ⋅ r_ctx).
  Proof.
    unfold URA.wf, URA.add in *. unseal "ra". destruct r_ctx; ss.
    rewrite ! union_empty in *. unfold union, NatMap.fold; ss. inv VALID. inv ADD. des_ifs.
    - econs; ss.
      + ii. des. eapply NatMapP.F.add_in_iff in H0. des.
        * subst. eauto.
        * eapply DISJOINT. eauto.
      + ii. eapply NatMapP.F.add_in_iff. rewrite union_comm in H. eapply NatMapP.F.add_in_iff in H. des; eauto.
    - eapply NatMapP.F.not_find_in_iff in NEW.
      eapply disjoint_false_iff' in Heq. des.
      eapply NatMapP.F.add_in_iff in Heq. rewrite NatMapP.F.empty_in_iff in Heq.
      des; ss; subst. firstorder.
  Qed.

  Lemma global_th_dealloc_context ths_ctx0 ths_usr r_ctx
        tid ths_ctx1
        (VALID: URA.wf (global_th ths_ctx0 ths_usr ⋅ local_th_context tid ⋅ r_ctx))
        (REMOVE: TIdSet.remove tid ths_ctx0 = ths_ctx1)
    :
    URA.wf (global_th ths_ctx1 ths_usr ⋅ URA.unit ⋅ r_ctx).

  Proof.
    rewrite URA.unit_id. unfold URA.wf, URA.add in *. unseal "ra". destruct r_ctx; ss.
    rewrite ! union_empty in *. unfold union, NatMap.fold in VALID; ss. des_ifs; inv VALID.
    econs; ss.
    - ii. des. eapply NatMapP.F.remove_in_iff in H; des. firstorder.
    - unfold TIdSet.empty, TIdSet.add in *. solve_andb; solve_disjoint.
      ii. eapply NatMapP.F.remove_in_iff. assert (tid = k \/ tid <> k) by lia; des.
      + subst. tauto.
      + unfold KeySetLE in LE_CTX. rewrite union_comm in LE_CTX. setoid_rewrite NatMapP.F.add_in_iff in LE_CTX. eauto.
  Qed.

  Lemma global_th_dealloc_user ths_ctx ths_usr0 r_ctx
        tid ths_usr1
        (VALID: URA.wf (global_th ths_ctx ths_usr0 ⋅ local_th_user tid ⋅ r_ctx))
        (REMOVE: TIdSet.remove tid ths_usr0 = ths_usr1)
    :
    URA.wf (global_th ths_ctx ths_usr1 ⋅ URA.unit ⋅ r_ctx).
  Proof.
    rewrite URA.unit_id. unfold URA.wf, URA.add in *. unseal "ra". destruct r_ctx; ss.
    rewrite ! union_empty in *. unfold union, NatMap.fold in VALID; ss. des_ifs; inv VALID.
    unfold TIdSet.empty, TIdSet.add in *. solve_disjoint.
    unfold KeySetLE in LE_USR. rewrite union_comm in LE_USR. setoid_rewrite NatMapP.F.add_in_iff in LE_USR.
    econs; ss.
    - ii. des. eapply NatMapP.F.remove_in_iff in H1. firstorder.
    - ii. rewrite NatMapP.F.remove_in_iff. split.
      + ii. subst. tauto.
      + firstorder.
  Qed.

End THREADS_RA.


Require Import Rupicola.Lib.Api.
Require Import Rupicola.Lib.Conditionals.

Section Gallina.
  Definition cswap {T} (swap: bool) (a b: T) : T * T :=
    if swap then (b, a) else (a, b).
End Gallina.

Section Compile.
  Context {width: Z} {BW: Bitwidth width} {word: word.word width} {mem: map.map word Byte.byte}.
  Context {locals: map.map String.string word}.
  Context {env: map.map String.string (list String.string * list String.string * Syntax.cmd)}.
  Context {ext_spec: bedrock2.Semantics.ExtSpec}.
  Context {word_ok : word.ok word} {mem_ok : map.ok mem}.
  Context {locals_ok : map.ok locals}.
  Context {env_ok : map.ok env}.
  Context {ext_spec_ok : Semantics.ext_spec.ok ext_spec}.

  (* FIXME cswap should be compilable as-is; no need for a lemma. *)
  (* There are two ways cswap could be compiled; you can either swap the local
     variables (the pointers), or you can leave the pointers and copy over the
     data. This version swaps the pointers without doing any copying. *)
  Lemma compile_cswap_nocopy : forall {tr} {mem: mem} {locals: locals} {functions} (swap: bool) {A} (x y: A),
    let v := cswap swap x y in
    forall {P} {pred: P v -> predicate}
      {k: nlet_eq_k P v} {k_impl}
      R (Data : word -> A -> _ -> Prop)
      swap_var x_var x_ptr y_var y_ptr tmp,

      map.get locals swap_var = Some (word.of_Z (Z.b2z swap)) ->
      map.get locals x_var = Some x_ptr ->
      map.get locals y_var = Some y_ptr ->

      (* tmp is a strictly temporary variable, confined to one part of the
         if-clause; it gets unset after use *)
      map.get locals tmp = None ->
      (Data x_ptr x * Data y_ptr y * R)%sep mem ->

      (let v := v in
       <{ Trace := tr;
          Memory := mem;
          Locals := map.put (map.put locals x_var (fst (cswap swap x_ptr y_ptr))) y_var
                      (snd (cswap swap x_ptr y_ptr));
          Functions := functions }>
       k_impl
       <{ pred (k v eq_refl) }>) ->
      <{ Trace := tr;
         Memory := mem;
         Locals := locals;
         Functions := functions }>
      cmd.seq
        (cmd.cond
           (expr.var swap_var)
           (cmd.seq
              (cmd.seq
                 (cmd.seq
                    (cmd.set tmp (expr.var x_var))
                    (cmd.set x_var (expr.var y_var)))
                 (cmd.set y_var (expr.var tmp)))
              (cmd.unset tmp))
           (cmd.skip))
        k_impl
      <{ pred (nlet_eq [x_var; y_var] v k) }>.
  Proof.
    intros; subst v; unfold cswap.
    simple eapply compile_if with
        (val_pred := fun _ tr' mem' locals' =>
                      tr' = tr /\
                      mem' = mem0 /\
                      locals' =
                      let locals := map.put locals0 x_var (if swap then y_ptr else x_ptr) in
                      let locals := map.put locals y_var (if swap then x_ptr else y_ptr) in
                      locals);
      repeat compile_step;
      repeat straightline'; subst_lets_in_goal; cbn; ssplit; eauto.
    - rewrite !map.remove_put_diff, !map.remove_put_same, map.remove_not_in by congruence.
      reflexivity.
    - rewrite (map.put_noop x_var x_ptr), map.put_noop by assumption.
      reflexivity.
    - cbv beta in *; repeat compile_step; cbn.
      destruct swap; eassumption.
  Qed.

  Lemma compile_cswap_pair : forall {tr mem locals functions} (swap: bool) {A} (x y: A * A),
    let v := cswap swap x y in
    forall {T} {pred: T -> predicate}
      {k: (A * A) * (A * A) -> T} {k_impl},
      (let __ := 0 in (* placeholder FIXME why? *)
       <{ Trace := tr;
          Memory := mem;
          Locals := locals;
          Functions := functions }>
       k_impl
       <{ pred (dlet (cswap swap (fst x) (fst y))
                     (fun xy1 =>
                        dlet (cswap swap (snd x) (snd y))
                             (fun xy2 =>
                                let x := (fst xy1, fst xy2) in
                                let y := (snd xy1, snd xy2) in
                                k (x, y)))) }>) ->
      <{ Trace := tr;
         Memory := mem;
         Locals := locals;
         Functions := functions }>
      k_impl
      <{ pred (dlet v k) }>.
  Proof.
    repeat straightline'.
    subst_lets_in_goal. destruct_products.
    destruct swap; cbv [cswap dlet] in *; cbn [fst snd] in *.
    all:eauto.
  Qed.
End Compile.

Section Helpers.
  Context {width: Z} {BW: Bitwidth width} {word: word.word width} {mem: map.map word Byte.byte}.
  Context {locals: map.map String.string word}.
  Context {env: map.map String.string (list String.string * list String.string * Syntax.cmd)}.
  Context {ext_spec: bedrock2.Semantics.ExtSpec}.
  Context {word_ok : word.ok word} {mem_ok : map.ok mem}.
  Context {locals_ok : map.ok locals}.
  Context {env_ok : map.ok env}.
  Context {ext_spec_ok : Semantics.ext_spec.ok ext_spec}.

  Lemma cswap_iff1
        {T} (pred : word ->T -> mem -> Prop) s pa pb a b :
    Lift1Prop.iff1
      ((pred (fst (cswap s pa pb)) (fst (cswap s a b)))
       * pred (snd (cswap s pa pb))
              (snd (cswap s a b)))%sep
      (pred pa a * pred pb b)%sep.
  Proof. destruct s; cbn [cswap fst snd]; ecancel. Qed.

  Lemma map_get_cswap_fst
        {key value} {map : map.map key value}
        (m : map.rep (map:=map)) s ka kb a b :
    map.get m ka = Some a ->
    map.get m kb = Some b ->
    map.get m (fst (cswap s ka kb)) = Some (fst (cswap s a b)).
  Proof. destruct s; cbn [cswap fst fst]; auto. Qed.

  Lemma map_get_cswap_snd
        {key value} {map : map.map key value}
        (m : map.rep (map:=map)) s ka kb a b :
    map.get m ka = Some a ->
    map.get m kb = Some b ->
    map.get m (snd (cswap s ka kb)) = Some (snd (cswap s a b)).
  Proof. destruct s; cbn [cswap fst snd]; auto. Qed.

  Lemma cswap_cases_fst {T} (P : T -> Prop) s a b :
    P a -> P b -> P (fst (cswap s a b)).
  Proof. destruct s; cbn [cswap fst snd]; auto. Qed.

  Lemma cswap_cases_snd {T} (P : T -> Prop) s a b :
    P a -> P b -> P (snd (cswap s a b)).
  Proof. destruct s; cbn [cswap fst snd]; auto. Qed.

  Lemma cswap_pair {A B} b (x y : A * B) :
    cswap b x y =
    (fst (cswap b (fst x) (fst y)), fst (cswap b (snd x) (snd y)),
     (snd (cswap b (fst x) (fst y)), snd (cswap b (snd x) (snd y)))).
  Proof. destruct b; destruct_products; reflexivity. Qed.
End Helpers.


Require Import PerformanceExperiments.Harness.
Require Import PerformanceExperiments.HarnessTimeAbstract.
Require Export PerformanceExperiments.rewrite_repeated_app_common.

Definition args_of_size (s : size) : list nat
  := match s with
     | Sanity => seq 1 3
     | SuperFast => List.map (fun x => x * 50) (seq 1 8)
     | Fast => (seq 1 100)
                 ++ List.map (fun x => x * 10) (seq 1 40)
                 ++ List.map (fun x => x * 100) (seq 1 10)
     | Medium => []
     | Slow => []
     | VerySlow => []
     end.

Ltac time_solve_goal0 n :=
  time_abstract_regression_cubic
    (time "fast_rewrite-regression-cubic" fast_rewrite).

Ltac run0 sz := Harness.runtests args_of_size default_describe_goal mkgoal redgoal time_solve_goal0 sz.

(*
Goal True.
  run0 Fast.
 *)


Set Warnings "-notation-overridden".

Require Import Category.Lib.
Require Export Category.Theory.Functor.
(* Require Export Category.Pending.Finite. *)

Generalizable All Variables.
Set Primitive Projections.
Set Universe Polymorphism.
Unset Transparent Obligations.

(*
Program Definition Span_Structure : Concrete_Structure := {|
  obs  := 3;
  arrs := [set (0, 0); (1, 1); (2, 2); (1, 0); (1, 2)]
|}.
Next Obligation.
  destruct n; intuition idtac.
  destruct n; intuition idtac.
  destruct n; intuition idtac.
  repeat (apply le_S_n in H).
  mini_omega.
Qed.
Next Obligation.
  destruct n, m, o; intuition idtac;
  try (inversion H4; subst; discriminate);
  try (inversion H0; subst; discriminate);
  destruct n, m; intuition idtac;
  try (inversion H4; subst; discriminate);
  try (inversion H0; subst; discriminate);
  destruct m, o; intuition idtac;
  try (inversion H4; subst; discriminate);
  try (inversion H0; subst; discriminate);
  destruct o; intuition idtac;
  try (inversion H4; subst; discriminate);
  try (inversion H0; subst; discriminate).
Qed.

Definition Span_Category := Concrete Span_Structure.

Program Definition Span {C : Category} {S x y : C} (f : S ~> x) (g : S ~> y) :
  Span_Category ⟶ C := {|
  fobj := fun z =>
    match proj1_sig z with
    | 0%nat => x
    | 1%nat => S
    | 2%nat => y
    | _ => _
    end;
  fmap := fun z w h => _
|}.
*)


(* 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 Import Bool.
Require Import Sumbool.
Require Import Arith.
Require Import ZArith NArith Nnat Ndec Ndigits.
From IntMap Require Import Allmaps.
Require Import Wf_nat.

Require Import BDDvar_ad_nat.
Require Import bdd1.
Require Import bdd2.
Require Import bdd3.
Require Import bdd4.
Require Import bdd5_1.

Lemma BDDneg_memo_OK_1_lemma_2_1' :
 forall (cfg : BDDconfig) (memo : BDDneg_memo),
 BDDconfig_OK cfg ->
 BDDneg_memo_OK_2 cfg memo ->
 BDDneg_memo_OK_2 cfg (BDDneg_memo_put memo BDDzero BDDone).
Proof.
  intro cfg.  elim cfg; clear cfg; intros bs y; elim y; clear y; intros share counter.
  intros memo H H0.  unfold BDDneg_memo_OK_2 in |- *.  intros node node' bound H1 H2.  unfold BDDneg_memo_put, BDDneg_memo_lookup in H1.
  rewrite (MapPut_semantics ad memo BDDzero BDDone node) in H1.  elim (sumbool_of_bool (Neqb BDDzero node)).
  intro y.  cut (BDDzero = node).  intro H3.  rewrite y in H1.  injection H1.  intros H4.
  rewrite <- H3.  rewrite <- H4.  split.  left; reflexivity.  elim bound.
  simpl in |- *.  elim H.  intros H5 H6.  elim H5; intros.  rewrite H7.  reflexivity.
  intros n H5.  simpl in |- *.  elim H.  intros H6 H7.  elim H6; intros.  simpl in H9.  rewrite H8.
  reflexivity.  apply Neqb_complete.  assumption.  intro y.  rewrite y in H1.
  unfold BDDneg_memo_OK_2 in H0.  apply H0.  assumption.  assumption.
Qed.

Lemma BDDneg_memo_OK_1_lemma_3_1' :
 forall (cfg : BDDconfig) (memo : BDDneg_memo),
 BDDconfig_OK cfg ->
 BDDneg_memo_OK_2 cfg memo ->
 BDDneg_memo_OK_2 cfg (BDDneg_memo_put memo BDDone BDDzero).
Proof.
  intro cfg.  elim cfg; clear cfg; intros bs y; elim y; clear y; intros share counter.
  intros memo H H0.  unfold BDDneg_memo_OK_2 in |- *.  intros node node' bound H1 H2.  unfold BDDneg_memo_put, BDDneg_memo_lookup in H1.
  rewrite (MapPut_semantics ad memo BDDone BDDzero node) in H1.  elim (sumbool_of_bool (Neqb BDDone node)).
  intro y.  cut (BDDone = node).  intro H3.  rewrite y in H1.  injection H1.  intros H4.
  rewrite <- H3.  rewrite <- H4.  split.  right; left; reflexivity.  elim bound.
  simpl in |- *.  elim H.  intros H5 H6.  elim H5; intros.  rewrite (proj1 H8).  reflexivity.
  intros n H5.  simpl in |- *.  elim H.  intros H6 H7.  elim H6; intros.  rewrite (proj1 H9).
  reflexivity.  apply Neqb_complete.  assumption.  intro y.  rewrite y in H1.  unfold BDDneg_memo_OK_2 in H0.
  apply H0.  assumption.  assumption.
Qed.

Lemma BDDneg_memo_OK_1_lemma_1_2' :
 forall (cfg : BDDconfig) (x : BDDvar) (l r node : ad)
   (n m : nat) (memo : BDDneg_memo),
 BDDconfig_OK cfg ->
 MapGet _ (fst cfg) node = Some (x, (l, r)) ->
 nat_of_N (var cfg node) < n ->
 n = S m ->
 BDDneg_memo_OK_2 (fst (BDDneg_2 (fst (BDDneg_2 cfg l m)) r m)) memo ->
 BDDneg_memo_OK_2 (fst (BDDneg_2 cfg node n))
   (BDDneg_memo_put memo node (snd (BDDneg_2 cfg node n))).
Proof.
  intro cfg.  elim cfg; clear cfg; intros bs y; elim y; clear y; intros share counter.
  intros x l r node n m memo H H0 H1.  intro H3.  intros H2.  unfold BDDneg_memo_OK_2 in |- *.
  intros node0 node' bound H4 H5.  unfold BDDneg_memo_put, BDDneg_memo_lookup in H4.  rewrite
   (MapPut_semantics ad memo node
      (snd (BDDneg_2 (bs, (share, counter)) node n)) node0)
    in H4.
  elim (sumbool_of_bool (Neqb node node0)).  intro y.  rewrite y in H4.  injection H4; intros.
  cut (node = node0).  intro H7.  rewrite <- H7.  rewrite <- H7 in H5.  split.
  apply nodes_preserved_2 with (cfg := (bs, (share, counter))).  right; right.  unfold in_dom in |- *.
  rewrite H0.  reflexivity.  unfold nodes_preserved in |- *.  cut (config_node_OK (bs, (share, counter)) node).
  cut
   (is_internal_node (bs, (share, counter)) node ->
    nat_of_N (var (bs, (share, counter)) node) < n).
  intros H8 H9.  exact
   (proj1 (proj2 (BDDneg_2_lemma n (bs, (share, counter)) node H H9 H8))).
  intro; assumption.  right; right.  unfold in_dom in |- *.  rewrite H0; reflexivity.
  apply BDDneg_memo_OK_1_lemma_1_1_1.  cut (config_node_OK (bs, (share, counter)) node).
  intro H8.  cut
   (is_internal_node (bs, (share, counter)) node ->
    nat_of_N (var (bs, (share, counter)) node) < n).
  intros H9.  exact (proj1 (BDDneg_2_lemma n (bs, (share, counter)) node H H8 H9)).
  intro H9.  assumption.  right.  right.  unfold in_dom in |- *.  rewrite H0.  reflexivity.
  apply nodes_preserved_2 with (cfg := (bs, (share, counter))).  right; right.  unfold in_dom in |- *.
  rewrite H0.  reflexivity.  unfold nodes_preserved in |- *.  cut (config_node_OK (bs, (share, counter)) node).
  cut
   (is_internal_node (bs, (share, counter)) node ->
    nat_of_N (var (bs, (share, counter)) node) < n).
  intros H8 H9.  exact
   (proj1 (proj2 (BDDneg_2_lemma n (bs, (share, counter)) node H H9 H8))).
  intro; assumption.  right; right.  unfold in_dom in |- *.  rewrite H0; reflexivity.
  rewrite <- H6.  cut (config_node_OK (bs, (share, counter)) node).  intro H8.
  cut
   (is_internal_node (bs, (share, counter)) node ->
    nat_of_N (var (bs, (share, counter)) node) < n).
  intros H9.  exact
   (proj1
      (proj2
         (proj2
            (proj2 (BDDneg_2_lemma n (bs, (share, counter)) node H H8 H9))))).
  intro; assumption.  right; right.  unfold in_dom in |- *.  rewrite H0; reflexivity.
  assumption.  rewrite <- H6.  cut (config_node_OK (bs, (share, counter)) node).
  intro H8.  cut
   (is_internal_node (bs, (share, counter)) node ->
    nat_of_N (var (bs, (share, counter)) node) < n).
  intro H9.  apply
   bool_fun_eq_trans
    with (bf2 := bool_fun_neg (bool_fun_of_BDD (bs, (share, counter)) node)).
  exact
   (proj2
      (proj2
         (proj2
            (proj2 (BDDneg_2_lemma n (bs, (share, counter)) node H H8 H9))))).
  apply bool_fun_eq_neg_1.  apply bool_fun_eq_symm.  apply bool_fun_preservation.
  assumption.  exact (proj1 (BDDneg_2_lemma n (bs, (share, counter)) node H H8 H9)).
  exact
   (proj1 (proj2 (BDDneg_2_lemma n (bs, (share, counter)) node H H8 H9))).
  assumption.  intro; assumption.  right; right.  unfold in_dom in |- *.  rewrite H0.
  reflexivity.  apply Neqb_complete.  assumption.  intro y.  rewrite y in H4.
  unfold BDDneg_memo_OK_2 in H2.  split.  apply
   nodes_preserved_2
    with
      (cfg := fst (BDDneg_2 (fst (BDDneg_2 (bs, (share, counter)) l m)) r m)).
  cut
   (is_internal_node
      (fst (BDDneg_2 (fst (BDDneg_2 (bs, (share, counter)) l m)) r m)) node0 ->
    nat_of_N
      (var (fst (BDDneg_2 (fst (BDDneg_2 (bs, (share, counter)) l m)) r m))
         node0) <
    S
      (nat_of_N
         (var
            (fst (BDDneg_2 (fst (BDDneg_2 (bs, (share, counter)) l m)) r m))
            node0))).
  intro H6.  exact
   (proj1
      (H2 node0 node'
         (S
            (nat_of_N
               (var
                  (fst
                     (BDDneg_2 (fst (BDDneg_2 (bs, (share, counter)) l m)) r
                        m)) node0))) H4 H6)).
  intro H6.  unfold lt in |- *.  apply le_n.  apply nodes_preserved_1 with (n := n) (x := x).
  assumption.  assumption.  assumption.  assumption.  apply BDDneg_memo_OK_1_lemma_1_1_1.
  cut (config_node_OK (bs, (share, counter)) node).  intro H6.  cut
   (is_internal_node (bs, (share, counter)) node ->
    nat_of_N (var (bs, (share, counter)) node) < n).
  intro H7.  exact (proj1 (BDDneg_2_lemma n (bs, (share, counter)) node H H6 H7)).
  intro H7.  assumption.  right.  right.  unfold in_dom in |- *.  rewrite H0.  reflexivity.
  apply
   nodes_preserved_2
    with
      (cfg := fst (BDDneg_2 (fst (BDDneg_2 (bs, (share, counter)) l m)) r m)).
  cut
   (is_internal_node
      (fst (BDDneg_2 (fst (BDDneg_2 (bs, (share, counter)) l m)) r m)) node0 ->
    nat_of_N
      (var (fst (BDDneg_2 (fst (BDDneg_2 (bs, (share, counter)) l m)) r m))
         node0) <
    S
      (nat_of_N
         (var
            (fst (BDDneg_2 (fst (BDDneg_2 (bs, (share, counter)) l m)) r m))
            node0))).
  intro H6.  exact
   (proj1
      (H2 node0 node'
         (S
            (nat_of_N
               (var
                  (fst
                     (BDDneg_2 (fst (BDDneg_2 (bs, (share, counter)) l m)) r
                        m)) node0))) H4 H6)).
  intro H6.  unfold lt in |- *.  apply le_n.  apply nodes_preserved_1 with (n := n) (x := x).  assumption.
  assumption.  assumption.  assumption.  cut
   (config_node_OK
      (fst (BDDneg_2 (fst (BDDneg_2 (bs, (share, counter)) l m)) r m)) node').
  intro H6.  cut
   (nodes_preserved
      (fst (BDDneg_2 (fst (BDDneg_2 (bs, (share, counter)) l m)) r m))
      (fst (BDDneg_2 (bs, (share, counter)) node n))).
  intro H7.  apply
   nodes_preserved_2
    with
      (cfg := fst (BDDneg_2 (fst (BDDneg_2 (bs, (share, counter)) l m)) r m)).
  assumption.  assumption.  apply nodes_preserved_1 with (x := x).  assumption.
  assumption.  assumption.  assumption.  apply BDDneg_memo_OK_lemma_1_4' with (memo := memo) (node := node0).
  apply BDDneg_2_config_OK_lemma_2 with (n := n) (x := x) (node := node).  assumption.  assumption.
  assumption.  assumption.  assumption.  cut
   (is_internal_node
      (fst (BDDneg_2 (fst (BDDneg_2 (bs, (share, counter)) l m)) r m)) node0 ->
    nat_of_N
      (var (fst (BDDneg_2 (fst (BDDneg_2 (bs, (share, counter)) l m)) r m))
         node0) <
    S
      (nat_of_N
         (var
            (fst (BDDneg_2 (fst (BDDneg_2 (bs, (share, counter)) l m)) r m))
            node0))).
  intro H6.  exact
   (proj1
      (H2 node0 node'
         (S
            (nat_of_N
               (var
                  (fst
                     (BDDneg_2 (fst (BDDneg_2 (bs, (share, counter)) l m)) r
                        m)) node0))) H4 H6)).
  intro H6.  unfold lt in |- *.  apply le_n.  assumption.  assumption.  apply
   bool_fun_eq_trans
    with
      (bf2 := bool_fun_of_BDD
                (fst
                   (BDDneg_2 (fst (BDDneg_2 (bs, (share, counter)) l m)) r m))
                node').
  apply bool_fun_preservation.  apply BDDneg_2_config_OK_lemma_2 with (node := node) (x := x) (n := n).
  assumption.  assumption.  assumption.  assumption.  cut (config_node_OK (bs, (share, counter)) node).
  intro H6.  cut
   (is_internal_node (bs, (share, counter)) node ->
    nat_of_N (var (bs, (share, counter)) node) < n).
  intro H7.  exact (proj1 (BDDneg_2_lemma n (bs, (share, counter)) node H H6 H7)).
  intro; assumption.  right; right.  unfold in_dom in |- *.  rewrite H0.  reflexivity.
  cut
   (nodes_preserved
      (fst (BDDneg_2 (fst (BDDneg_2 (bs, (share, counter)) l m)) r m))
      (fst (BDDneg_2 (bs, (share, counter)) node n))).
  unfold nodes_preserved in |- *.  intro H6.  assumption.  apply nodes_preserved_1 with (x := x).
  assumption.  assumption.  assumption.  assumption.  apply BDDneg_memo_OK_lemma_1_4' with (memo := memo) (node := node0).
  apply BDDneg_2_config_OK_lemma_2 with (node := node) (x := x) (n := n).  assumption.  assumption.
  assumption.  assumption.  assumption.  cut
   (is_internal_node
      (fst (BDDneg_2 (fst (BDDneg_2 (bs, (share, counter)) l m)) r m)) node0 ->
    nat_of_N
      (var (fst (BDDneg_2 (fst (BDDneg_2 (bs, (share, counter)) l m)) r m))
         node0) <
    S
      (nat_of_N
         (var
            (fst (BDDneg_2 (fst (BDDneg_2 (bs, (share, counter)) l m)) r m))
            node0))).
  intro H6.  exact
   (proj1
      (H2 node0 node'
         (S
            (nat_of_N
               (var
                  (fst
                     (BDDneg_2 (fst (BDDneg_2 (bs, (share, counter)) l m)) r
                        m)) node0))) H4 H6)).
  intro H6.  unfold lt in |- *.  apply le_n.  assumption.  apply
   bool_fun_eq_trans
    with
      (bf2 := bool_fun_neg
                (bool_fun_of_BDD
                   (fst
                      (BDDneg_2 (fst (BDDneg_2 (bs, (share, counter)) l m)) r
                         m)) node0)).
  apply BDDneg_memo_OK_bool_fun_1' with (memo := memo).  apply BDDneg_2_config_OK_lemma_2 with (node := node) (x := x) (n := n).
  assumption.  assumption.  assumption.  assumption.  assumption.  cut
   (is_internal_node
      (fst (BDDneg_2 (fst (BDDneg_2 (bs, (share, counter)) l m)) r m)) node0 ->
    nat_of_N
      (var (fst (BDDneg_2 (fst (BDDneg_2 (bs, (share, counter)) l m)) r m))
         node0) <
    S
      (nat_of_N
         (var
            (fst (BDDneg_2 (fst (BDDneg_2 (bs, (share, counter)) l m)) r m))
            node0))).
  intro H6.  exact
   (proj1
      (H2 node0 node'
         (S
            (nat_of_N
               (var
                  (fst
                     (BDDneg_2 (fst (BDDneg_2 (bs, (share, counter)) l m)) r
                        m)) node0))) H4 H6)).
  intro H6.  unfold lt in |- *.  apply le_n.  assumption.  apply bool_fun_eq_neg_1.  apply bool_fun_eq_symm.
  apply bool_fun_preservation.  apply BDDneg_2_config_OK_lemma_2 with (n := n) (x := x) (node := node).
  assumption.  assumption.  assumption.  assumption.  cut (config_node_OK (bs, (share, counter)) node).
  intro H6.  cut
   (is_internal_node (bs, (share, counter)) node ->
    nat_of_N (var (bs, (share, counter)) node) < n).
  intro H7.  exact (proj1 (BDDneg_2_lemma n (bs, (share, counter)) node H H6 H7)).
  intro; assumption.  right; right.  unfold in_dom in |- *.  rewrite H0.  reflexivity.
  cut
   (nodes_preserved
      (fst (BDDneg_2 (fst (BDDneg_2 (bs, (share, counter)) l m)) r m))
      (fst (BDDneg_2 (bs, (share, counter)) node n))).
  unfold nodes_preserved in |- *.  intro H6.  assumption.  apply nodes_preserved_1 with (x := x).
  assumption.  assumption.  assumption.  assumption.  cut
   (is_internal_node
      (fst (BDDneg_2 (fst (BDDneg_2 (bs, (share, counter)) l m)) r m)) node0 ->
    nat_of_N
      (var (fst (BDDneg_2 (fst (BDDneg_2 (bs, (share, counter)) l m)) r m))
         node0) <
    S
      (nat_of_N
         (var
            (fst (BDDneg_2 (fst (BDDneg_2 (bs, (share, counter)) l m)) r m))
            node0))).
  intro H6.  exact
   (proj1
      (H2 node0 node'
         (S
            (nat_of_N
               (var
                  (fst
                     (BDDneg_2 (fst (BDDneg_2 (bs, (share, counter)) l m)) r
                        m)) node0))) H4 H6)).
  intro H6.  unfold lt in |- *.  apply le_n.
Qed.

Lemma BDDneg_1_lemma' :
 forall (bound : nat) (arg : BDDconfig * ad * BDDneg_memo),
 BDDconfig_OK (fst (fst arg)) ->
 config_node_OK (fst (fst arg)) (snd (fst arg)) ->
 BDDneg_memo_OK_2 (fst (fst arg)) (snd arg) ->
 (is_internal_node (fst (fst arg)) (snd (fst arg)) ->
  nat_of_N (var (fst (fst arg)) (snd (fst arg))) < bound) ->
 fst (BDDneg_1 arg bound) = BDDneg_2 (fst (fst arg)) (snd (fst arg)) bound /\
 BDDneg_memo_OK_2 (fst (fst (BDDneg_1 arg bound))) (snd (BDDneg_1 arg bound)).
Proof.
  intro bound.  apply
   lt_wf_ind
    with
      (P := fun bound : nat =>
            forall arg : BDDconfig * ad * BDDneg_memo,
            BDDconfig_OK (fst (fst arg)) ->
            config_node_OK (fst (fst arg)) (snd (fst arg)) ->
            BDDneg_memo_OK_2 (fst (fst arg)) (snd arg) ->
            (is_internal_node (fst (fst arg)) (snd (fst arg)) ->
             nat_of_N (var (fst (fst arg)) (snd (fst arg))) < bound) ->
            fst (BDDneg_1 arg bound) =
            BDDneg_2 (fst (fst arg)) (snd (fst arg)) bound /\
            BDDneg_memo_OK_2 (fst (fst (BDDneg_1 arg bound)))
              (snd (BDDneg_1 arg bound))).
  intros n H arg.  elim arg; clear arg; intro y.  elim y; clear y.  intros cfg node memo.
  intros H0 H1 H2 H3.  elim
   (option_sum _
      (BDDneg_memo_lookup (snd (cfg, node, memo))
         (snd (fst (cfg, node, memo))))).
  intro y.  elim y; clear y; intros node' H4.  rewrite (BDDneg_1_lemma_1 (cfg, node, memo) node' n H4).
  simpl in |- *.  split.  simpl in H2.  unfold BDDneg_memo_OK_2 in H2.  rewrite (proj2 (H2 node node' n H4 H3)).
  reflexivity.  assumption.  intro y.  elim
   (option_sum _
      (MapGet _ (fst (fst (fst (cfg, node, memo))))
         (snd (fst (cfg, node, memo))))).
  intro y0.  elim y0; clear y0.  intro x.  elim x; clear x.  intros x y0.  elim y0; clear y0; intros l r H4.
  elim (nat_sum n).  intros y0.  elim y0; clear y0.  intros m H5.  rewrite (BDDneg_1_lemma_4 (cfg, node, memo) x l r n m H5 y H4).

  simpl in |- *.  cut
   (fst (BDDneg_1 (cfg, l, memo) m) =
    BDDneg_2 (fst (fst (cfg, l, memo))) (snd (fst (cfg, l, memo))) m /\
    BDDneg_memo_OK_2 (fst (fst (BDDneg_1 (cfg, l, memo) m)))
      (snd (BDDneg_1 (cfg, l, memo) m))).
  intro H6.  cut
   (fst
      (BDDneg_1
         (fst
            (fst
               (BDDneg_1
                  (fst (fst (cfg, node, memo)), l, snd (cfg, node, memo)) m)),
         r,
         snd
           (BDDneg_1 (fst (fst (cfg, node, memo)), l, snd (cfg, node, memo))
              m)) m) =
    BDDneg_2
      (fst
         (fst
            (fst
               (fst
                  (BDDneg_1
                     (fst (fst (cfg, node, memo)), l, snd (cfg, node, memo))
                     m)), r,
            snd
              (BDDneg_1
                 (fst (fst (cfg, node, memo)), l, snd (cfg, node, memo)) m))))
      (snd
         (fst
            (fst
               (fst
                  (BDDneg_1
                     (fst (fst (cfg, node, memo)), l, snd (cfg, node, memo))
                     m)), r,
            snd
              (BDDneg_1
                 (fst (fst (cfg, node, memo)), l, snd (cfg, node, memo)) m))))
      m /\
    BDDneg_memo_OK_2
      (fst
         (fst
            (BDDneg_1
               (fst
                  (fst
                     (BDDneg_1
                        (fst (fst (cfg, node, memo)), l,
                        snd (cfg, node, memo)) m)), r,
               snd
                 (BDDneg_1
                    (fst (fst (cfg, node, memo)), l, snd (cfg, node, memo)) m))
               m)))
      (snd
         (BDDneg_1
            (fst
               (fst
                  (BDDneg_1
                     (fst (fst (cfg, node, memo)), l, snd (cfg, node, memo))
                     m)), r,
            snd
              (BDDneg_1
                 (fst (fst (cfg, node, memo)), l, snd (cfg, node, memo)) m))
            m))).  intro H7.  simpl in H6, H7.
  rewrite (proj1 H7).  rewrite (proj1 H6).  cut
   (BDDmake (fst (BDDneg_2 (fst (BDDneg_2 cfg l m)) r m)) x
      (snd (BDDneg_2 cfg l m)) (snd (BDDneg_2 (fst (BDDneg_2 cfg l m)) r m)) =
    BDDneg_2 cfg node n).

  intro H8.  split.  assumption.  rewrite (proj1 H6) in H7.
  elim H7; intros. rewrite H9 in H7. clear H9 H10. (* instead of Rewrite (proj1 ? ? H7) in H7. which does not work in 6.3. *)
  rewrite H8.  apply BDDneg_memo_OK_1_lemma_1_2' with (x := x) (l := l) (r := r) (m := m).  assumption.
  assumption.  apply H3.  split with x; split with l; split with r; assumption.
  assumption.  exact (proj2 H7).  rewrite H5.  simpl in |- *.  simpl in H4.  rewrite H4.
  reflexivity.  apply H.  rewrite H5.  unfold lt in |- *.  apply le_n.  simpl in |- *.  rewrite (proj1 H6).
  simpl in |- *.  cut (config_node_OK cfg l).  intro.  cut (is_internal_node cfg l -> nat_of_N (var cfg l) < m).
  intros H8.  exact (proj1 (BDDneg_2_lemma m cfg l H0 H7 H8)).  intro H8.  apply lt_trans_1 with (y := nat_of_N (var cfg node)).
  cut (l = low cfg node).  intro H9.  rewrite H9.  apply BDDcompare_lt.  apply BDDvar_ordered_low.

  assumption.  split with x; split with l; split with r.  assumption.  rewrite <- H9; assumption.
  unfold low in |- *.  simpl in H4.  rewrite H4.  reflexivity.  rewrite <- H5.  apply H3.
  simpl in |- *.  split with x; split with l; split with r; assumption.  cut (l = low cfg node); intros.
  rewrite H7.  apply low_OK.  assumption.  split with x; split with l; split with r; assumption.
  unfold low in |- *; simpl in H4; rewrite H4; reflexivity.  simpl in |- *.  rewrite (proj1 H6).
  simpl in |- *.  cut (config_node_OK cfg l).  intro H7.  cut (is_internal_node cfg l -> nat_of_N (var cfg l) < m).
  intro H8.  cut (config_node_OK cfg r).  intro H9.  elim H9; intro.  rewrite H10.
  left; reflexivity.  elim H10; intro.  rewrite H11; right; left; reflexivity.
  right; right.  unfold in_dom in |- *.  cut (is_internal_node cfg r).  intro H12.  inversion H12.
  inversion H13.  inversion H14.  simpl in H0.  simpl in |- *.  cut
   (MapGet (BDDvar * (ad * ad)) (fst (fst (BDDneg_2 cfg l m))) r =
    Some (x0, (x1, x2))).
  intro H16.  rewrite H16.  reflexivity.  exact (proj1 (proj2 (BDDneg_2_lemma m cfg l H0 H7 H8)) x0 x1 x2 r H15).
  apply in_dom_is_internal.  assumption.  cut (r = high cfg node).  intro H9.  rewrite H9.
  apply high_OK.  assumption.  split with x; split with l; split with r; assumption.
  unfold high in |- *.  simpl in H4; rewrite H4; reflexivity.  intro H8.  apply lt_trans_1 with (y := nat_of_N (var cfg node)).
  apply BDDcompare_lt.  cut (l = low cfg node).  intro; rewrite H9.  apply BDDvar_ordered_low.
  assumption.  split with x; split with l; split with r; assumption.  rewrite <- H9; assumption.
  unfold low in |- *; simpl in H4; rewrite H4; reflexivity.  rewrite <- H5; apply H3.
  simpl in |- *.  split with x; split with l; split with r; assumption.  cut (l = low cfg node).
  intro H7.  rewrite H7.  apply low_OK.  assumption.  split with x; split with l; split with r; assumption.
  unfold low in |- *; simpl in H4; rewrite H4; reflexivity.  simpl in |- *.  exact (proj2 H6).

  simpl in |- *.  rewrite (proj1 H6).  simpl in |- *.  intro H7.  cut (var (fst (BDDneg_2 cfg l m)) r = var cfg r).
  intro H8.  rewrite H8.  apply lt_trans_1 with (y := nat_of_N (var cfg node)).  apply BDDcompare_lt.
  cut (r = high cfg node).  intro H9.  rewrite H9.  apply BDDvar_ordered_high.  assumption.
  split with x; split with l; split with r; assumption.  cut (config_node_OK cfg (high cfg node)).
  intro H10.  elim H10; intro.  inversion H7.  inversion H12.  inversion H13.
  rewrite H9 in H14; rewrite H11 in H14.  cut (BDDconfig_OK (fst (BDDneg_2 cfg l m))).
  intro H15.  rewrite (config_OK_zero (fst (BDDneg_2 cfg l m)) H15) in H14.  discriminate H14.
  cut (config_node_OK cfg l).  intro H15.  cut (is_internal_node cfg l -> nat_of_N (var cfg l) < m).
  intro H16.  exact (proj1 (BDDneg_2_lemma m cfg l H0 H15 H16)).  intro H16.  apply lt_trans_1 with (y := nat_of_N (var cfg node)).
  cut (l = low cfg node).  intro H17.  rewrite H17.  apply BDDcompare_lt.  apply BDDvar_ordered_low.
  assumption.  split with x; split with l; split with r; assumption.  rewrite <- H17; assumption.
  unfold low in |- *; simpl in H4; rewrite H4.  reflexivity.  rewrite <- H5; apply H3.
  simpl in |- *.  split with x; split with l; split with r; assumption.  cut (l = low cfg node).
  intro H15.  rewrite H15.  apply low_OK.  assumption.  split with x; split with l; split with r; assumption.
  unfold low in |- *; simpl in H4; rewrite H4; reflexivity.  elim H11; intro.  rewrite H9 in H7.
  rewrite H12 in H7.  inversion H7.  inversion H13.  inversion H14.  cut (BDDconfig_OK (fst (BDDneg_2 cfg l m))).
  intro H16.  rewrite (config_OK_one (fst (BDDneg_2 cfg l m)) H16) in H15.  discriminate H15.
  cut (config_node_OK cfg l).  intro H16.  cut (is_internal_node cfg l -> nat_of_N (var cfg l) < m).

  intros H17.  exact (proj1 (BDDneg_2_lemma m cfg l H0 H16 H17)).  intro H17.
  apply lt_trans_1 with (y := nat_of_N (var cfg node)).  cut (l = low cfg node).
  intro H18.  rewrite H18.  apply BDDcompare_lt.  apply BDDvar_ordered_low.  assumption.
  split with x; split with l; split with r.  assumption.  rewrite <- H18; assumption.
  unfold low in |- *.  simpl in H4.  rewrite H4.  reflexivity.  rewrite <- H5.  apply H3.
  simpl in |- *.  split with x; split with l; split with r; assumption.  cut (l = low cfg node); intros.
  rewrite H16.  apply low_OK.  assumption.  split with x; split with l; split with r; assumption.
  unfold low in |- *; simpl in H4; rewrite H4; reflexivity.  apply in_dom_is_internal.
  assumption.  apply high_OK.  assumption.  split with x; split with l; split with r; assumption.
  unfold high in |- *.  simpl in H4; rewrite H4; reflexivity.  rewrite <- H5; apply H3.
  simpl in |- *.  split with x; split with l; split with r; assumption.  inversion H7.
  inversion H8.  inversion H9.  unfold var in |- *.  rewrite H10.  cut (l = low cfg node).
  cut (r = high cfg node).  intros H11 H12.  cut (config_node_OK cfg l).  cut (config_node_OK cfg r).
  intros H13 H14.  cut (BDDconfig_OK (fst (BDDneg_2 cfg l m))).  intro H15.  elim H13; intro.

  rewrite H16 in H10.  rewrite (config_OK_zero (fst (BDDneg_2 cfg l m)) H15) in H10; discriminate.
  elim H16; intro.  rewrite H17 in H10.  rewrite (config_OK_one (fst (BDDneg_2 cfg l m)) H15) in H10; discriminate.
  elim (option_sum _ (MapGet (BDDvar * (ad * ad)) (fst cfg) r)).  intro y0.  elim y0; intro x3.
  elim x3; intro y1; intro y2.  elim y2; intros y3 y4 y5.  rewrite y5.  cut (is_internal_node cfg l -> nat_of_N (var cfg l) < m).
  intro H18.  cut
   (MapGet (BDDvar * (ad * ad)) (fst (fst (BDDneg_2 cfg l m))) r =
    Some (y1, (y3, y4))).
  intro H19.  rewrite H19 in H10.  injection H10.  intros H20 H21 H22.  rewrite H22; reflexivity.
  exact (proj1 (proj2 (BDDneg_2_lemma m cfg l H0 H14 H18)) y1 y3 y4 r y5).
  intro H18.  apply lt_trans_1 with (y := nat_of_N (var cfg node)).  apply BDDcompare_lt.
  rewrite H12.  apply BDDvar_ordered_low.  assumption.  split with x; split with l; split with r; assumption.
  rewrite <- H12.  assumption.  rewrite <- H5.  apply H3.  simpl in |- *.  split with x; split with l; split with r; assumption.
  intro y0.  unfold in_dom in H17.  rewrite y0 in H17.  discriminate.  cut (is_internal_node cfg l -> nat_of_N (var cfg l) < m).
  intro H15.  exact (proj1 (BDDneg_2_lemma m cfg l H0 H14 H15)).  intro H15.  apply lt_trans_1 with (y := nat_of_N (var cfg node)).

  apply BDDcompare_lt.  rewrite H12.  apply BDDvar_ordered_low.  assumption.
 split with x; split with l; split with r; assumption.  rewrite <- H12; assumption.
  rewrite <- H5; apply H3.  simpl in |- *.  split with x; split with l; split with r; assumption.
  rewrite H11.  apply high_OK.  assumption.  split with x; split with l; split with r; assumption.
  rewrite H12.  apply low_OK.  assumption.  split with x; split with l; split with r; assumption.
  unfold high in |- *; simpl in H4; rewrite H4; reflexivity.  unfold low in |- *; simpl in H4; rewrite H4; reflexivity.
  apply H.  rewrite H5.  unfold lt in |- *.  apply le_n.  simpl in |- *.  assumption.  simpl in |- *.
  cut (l = low cfg node).  intro; rewrite H6.  apply low_OK.  assumption.
  split with x; split with l; split with r; assumption.  unfold low in |- *; simpl in H4; rewrite H4; reflexivity.
  simpl in |- *.  assumption.  simpl in |- *.  intro H6.  apply lt_trans_1 with (y := nat_of_N (var cfg node)).
  apply BDDcompare_lt.  cut (l = low cfg node).  intro H7.  rewrite H7.  apply BDDvar_ordered_low.
  assumption.  split with x; split with l; split with r; assumption.  rewrite <- H7; assumption.
  unfold low in |- *; simpl in H4; rewrite H4; reflexivity.  rewrite <- H5; apply H3.
  simpl in |- *.  split with x; split with l; split with r; assumption.  intro y0.  rewrite y0.
  rewrite (BDDneg_1_lemma_3 (cfg, node, memo) x l r y H4).  simpl in |- *.  simpl in H4.
  rewrite H4.  split.  reflexivity.  unfold BDDneg_memo_OK_2 in |- *.  intros node0 node' bound0 H5 H6.  unfold BDDneg_memo_lookup in H5.
  rewrite (newMap_semantics ad node0) in H5.  discriminate.  simpl in |- *.  intro y0.  rewrite (BDDneg_1_lemma_2 (cfg, node, memo) n y y0).
  simpl in |- *.  unfold BDDneg_2 in |- *.  elim n; rewrite y0.  elim (Neqb node BDDzero).

  simpl in |- *.  split.  reflexivity.  apply BDDneg_memo_OK_1_lemma_2_1'.  assumption.
  assumption.  simpl in |- *.  split.  reflexivity.  apply BDDneg_memo_OK_1_lemma_3_1'.
  assumption. assumption.
  fold BDDneg_2 in |- *.  intro n0.  intro H4.  elim (Neqb node BDDzero).  simpl in |- *.  split.
  reflexivity.  apply BDDneg_memo_OK_1_lemma_2_1'.  assumption.  assumption.
  simpl in |- *.  split.
  reflexivity.  apply BDDneg_memo_OK_1_lemma_3_1'.  assumption.  assumption.
Qed.