Require Import Setoid.
Require Import Classical.

(***********
 *         *
 * Bennett *
 *         *
 ***********)
Parameter Entity: Set.
Parameter F : Entity -> Entity -> Prop.
Parameter Ps : Entity -> Entity -> Prop.
Definition P x y := exists s, F x s /\ Ps s y.
Definition PP x y := P x y /\ ~ P y x.
Definition O x y := exists z, P z x /\ P z y.
Definition Os x y := exists z, Ps z x /\ Ps z y.
Definition PPs x y := Ps x y /\ ~ F y x.

(* Only Slots are Filled *)
Axiom only_slots_are_filled : forall x y,
  F x y -> exists z, Ps y z.

(* Slots Cannot Fill *)
Axiom slots_cannot_fill : forall x y,
  F x y -> ~exists z, Ps x z.

(* Slots Don’t Have Slots *)
Axiom slots_dont_have_slots : forall x y,
  Ps x y -> ~exists z, Ps z x.

(* Filler Irreflexivity *)
Theorem BT1 : forall x,
  ~ F x x.
Proof.
  intros x h.
  apply only_slots_are_filled in h as h1.
  apply slots_cannot_fill in h as h2.
  contradiction.
Qed.

(* Filler Asymmetry *)
Theorem BT2 : forall x y,
  F x y -> ~ F y x.
Proof.
  intros x y H.
  apply only_slots_are_filled in H.
  intro h.
  apply slots_cannot_fill in h.
  contradiction.
Qed.

(* Filler Transitivity *)
Theorem BT3 : forall x y z,
  (F x y /\ F y z) -> F x z.
Proof.
  intros x y z [].
  apply only_slots_are_filled in H as [].
  apply slots_cannot_fill in H0 as [].
  exists x0.
  apply H.
Qed.

(* Slot Irreflexivity *)
Theorem BT4 : forall x,
  ~Ps x x.
Proof.
  intros x h.
  apply slots_dont_have_slots in h as h1.
  destruct h1.
  exists x.
  assumption.
Qed.

(* Slot Asymmetry *)
Theorem BT5 : forall x y,
  Ps x y -> ~ Ps y x.
Proof.
  intros x y H h.
  apply slots_dont_have_slots in h as [].
  exists x.
  assumption.
Qed.

(* Slot Transitivity *)
Theorem BT6 : forall x y z,
  (Ps x y /\ Ps y z) -> Ps x z.
Proof.
  intros x y z [].
  apply slots_dont_have_slots in H0 as [].
  exists x.
  assumption.
Qed.

(* Improper Parthood Slots *)
Axiom whole_improper_slots : forall x,
  (exists y, Ps y x) -> (exists z, Ps z x /\ F x z).

(* Slot Inheritance *)
Axiom slot_inheritance : forall x y z1 z2,
  (Ps z1 y /\ F x z1) /\ Ps z2 x -> Ps z2 y.

(* Mutual Occupancy is Identity *)
Axiom mutual_occupancy : forall x y z1 z2,
  (Ps z1 y /\ F x z1) /\ (Ps z2 x /\ F y z2) -> x = y.

(* Single Occupancy *)
Axiom single_occupancy : forall x y,
  Ps x y -> exists! z, F z x.

(* Parthood Transitivity *)
Theorem parthood_transitivity : forall x y z,
  (P x y /\ P y z) -> P x z.
Proof.
  firstorder.
  unfold P.
  eauto 6 using slot_inheritance.
Qed.

(* Anti-Symmetry *)
Theorem BT8 : forall x y,
  (P x y /\ P y x) -> x = y.
Proof.
  unfold P.
  firstorder.
  apply mutual_occupancy with (z1 := x1) (z2 := x0).
  auto.
Qed.

(* Conditional Reflexivity *)
Theorem BT9 : forall x,
  (exists z, Ps z x) -> P x x.
Proof.
  intros x h.
  apply whole_improper_slots in h as [y ].
  unfold P.
  exists y.
  apply and_comm; assumption.
Qed.

(* Parts <-> Slots *)
Theorem BT11 : forall y,
  ((exists x, P x y) <-> (exists z, Ps z y)).
Proof.
  intro y.
  unfold P.
  split.
  - intros [x [s []]].
    exists s.
    assumption.
  - intros [z Pszy].
    apply single_occupancy in Pszy as H1.
    destruct H1 as [x []].
    exists x, z.
    split; assumption.
Qed.

(* Composites <-> Slot-Composites *)
Theorem BT12 : forall y,
  ((exists x, PP x y) <-> (exists z, PPs z y)).
Proof.
  unfold PP, PPs, P.
  intro b.
  split.
  (* left to right *)
  - intros [a [[c [Fac Pscb]] nPba]].
    exists c.
    split.
    -- apply Pscb.
    -- pose proof (single_occupancy _ _ Pscb) as [d [Fdc Uc]].
       intros Fbc.
       pose proof (Uc a Fac). subst.
       pose proof (Uc b Fbc). subst.
       apply nPba.
       exists c; split.
       apply Fbc.
       apply Pscb.
  (* right to left *)
  - intros [a [Psab nFba]].
    pose proof (single_occupancy _ _ Psab) as [c [Fca Uc]].
    exists c.
    split.
    + exists a; split; eauto.
    + intros [d [Fbd Psfc]].
    apply nFba.
    assert (b = c) as Heqbc.
    * eapply mutual_occupancy with (z1 := d) (z2 := a).
      repeat split; assumption.
    * rewrite Heqbc in *.
      apply Fca.
Qed.

(* Slot Strong Supplementation *)
Axiom BA8 : forall x y,
  (exists z, Ps z x) /\ (exists z, Ps z y) ->
    ((~exists z, Ps z x /\ F y z) ->
      (exists z, Ps z y /\ ~Ps z x)).

(* Slot Weak Supplementation *)
Theorem BT13 : forall x y,
  (PP x y -> (exists z, Ps z y /\ ~ Ps z x)).
Proof.
  intros a b [[c [Fac Pscb]] nPba].
  pose proof (whole_improper_slots b).
  destruct H.
  exists c.
  exact Pscb.
  exists x.
  split.
  apply H.
  intro h.
  apply nPba.
  destruct H.
  exists x.
  split; assumption.
Qed.

(* Slot Extensionality *)
(* This is not a theorem of the theory. *)
Theorem BT14 : forall x y,
  ((exists z, PP z x) \/ (exists z, PP z y)) ->
    ((x = y) <->
      (exists z, PPs z x <-> PPs z y)).
Abort.

(**********************
 *                    *
 * Tarbouriech et al. *
 *                    *
 **********************)

(* Anti-Inheritance *)
Axiom anti_inheritance : forall x y s t,
  x <> y /\ Ps s y /\ F x s /\ Ps t x -> ~Ps t y.

(* Single Owner *)
Axiom single_owner : forall s x,
  Ps s x -> forall y, Ps s y -> x = y.

Definition IPs x y := Ps x y /\ F y x.

(* Slots are either proper or improper. *)
Theorem either_proper_or_improper : forall s x,
  Ps s x -> PPs s x /\ ~IPs s x \/ ~PPs s x /\ IPs s x.
Proof.
  intros s x Pssx.
  destruct (classic (F x s)) as [yesF|notF];
  [right|left];
  repeat split; try assumption;
  apply or_not_and;
  right;
  intuition.
Qed.

(* Improper Slots are only owned by their Filler *)
Theorem unique_owner_improper_slot : forall x s,
  IPs s x -> (forall y, Ps s y -> x = y).
Proof.
  intros x s [Pssx Fxs] y Pssy.
  pose proof (single_owner s y Pssy) as UniqueOwner.
  apply UniqueOwner in Pssx as H.
  rewrite H in UniqueOwner.
  symmetry; assumption.
Qed.

(* *)
Theorem proper_part_in_proper_slot : forall x y,
  PP y x -> (exists s, Ps s x /\ F y s /\ ~Ps s y).
Proof.
  intros x y [[s [Fys Pssx]] nPxy].
  exists s.
  repeat split; try assumption.
  intro Pssy.
  destruct nPxy.
  pose proof (single_owner s x Pssx) as UniqueSOwner.
  apply UniqueSOwner in Pssy.
  rewrite <- Pssy.
  apply BT9.
  exists s; assumption.
Qed.

(* Additional Improper Parthood Slots *)
Axiom A3 : forall x s, F x s -> exists t, IPs t x.

(* General Conditional Reflexivity *)
Theorem general_conditional_refl : forall x,
  (exists s, (Ps s x \/ F x s)) -> P x x.
Proof.
  unfold P.
  intros x [s []].
  - pose proof (whole_improper_slots x).
    destruct H0.
    exists s.
    apply H.
    exists x0.
    apply and_comm.
    apply H0.
  - pose proof (A3 x s).
    destruct H0.
    apply H.
    unfold IPs in H0.
    exists x0.
    apply and_comm.
    assumption.
Qed.

(* Only One Improper Slot per Filler *)
Axiom unique_improper_slot : forall x s t,
  Ps s x -> F x s -> Ps t x -> F x t
    -> s = t.

(***************
 * Composition *
 ***************)

Parameter C : Entity -> Entity -> Entity -> Prop.

(* Composition Existence *)
Axiom composition_existence : forall s t y,
  ((F y s /\ Ps t y) -> (exists u, C u s t)).

Axiom composition_constraints : forall s t u,
  (C u s t -> (exists y, F y s /\ Ps t y)).

(* Composition Unicity *)
Axiom composition_unicity : forall s t u v,
  C u s t /\ C v s t -> u = v.

Axiom composition_semi_func : forall s t u v,
  C v s t /\ C v s u -> t = u.

(* Same Filler *)
Axiom composition_same_filler : forall u s t,
  C u s t -> (exists x, F x u /\ F x t).

(* Same Owner *)
Axiom composition_same_owner : forall u s t,
  C u s t -> (exists x, Ps u x /\ Ps s x).

(* Conditional Non-Commutativity *)
Theorem conditional_no_commutativity : forall s t,
  ((exists u, (C u s t /\ s <> t)) -> ~(exists u', C u' t s)).
Proof.
  intros t u [s []] [v].
  apply composition_constraints in H as [x []].
  apply composition_constraints in H1 as [y []].
  pose proof (mutual_occupancy x y t u (conj (conj H3 H) (conj H2 H1))).
  rewrite <- H4 in H1, H3.
  clear H4 y.
  pose proof (unique_improper_slot x t u H3 H H2 H1).
  contradiction.
Qed.

(* Composition Associativity *)
Axiom composition_associativity : forall s t u a b c d,
  ((C a s t /\ C b a u) /\ (C d s c /\ C c t u) -> b = d).

(* Proper-Improper Composition *)
Axiom pro_imp_composition : forall s t x,
  (IPs s x /\ F x t -> C t t s).

(* Improper-Proper Composition *)
Axiom imp_pro_composition : forall s t x,
  (IPs s x /\ Ps t x -> C t s t).

(* Improper-Improper Composition *)
Theorem imp_imp_composition : forall s x,
  (IPs s x -> C s s s).
Proof.
  intros s x IPssx.
  assert (H := IPssx).
  destruct H as [Pssx Fxs].
  pose proof (imp_pro_composition s s x (conj IPssx Pssx)).
  assumption.
Qed.

(****************
 * Part of Slot *
 ****************)

Definition PoS s t := exists u, C s t u.

(* Conditional PoS Reflexivity *)
Theorem conditional_pos_refl : forall s x,
  Ps s x -> PoS s s.
Proof.
  intros.
  unfold PoS.
  apply single_occupancy in H as [z [Fzs UniqueFzs]].
  pose proof (general_conditional_refl z) as [].
  exists s.
  right.
  assumption.
  exists x0.
  pose proof (pro_imp_composition x0 s z).
  unfold IPs in H0.
  apply H0.
  destruct H.
  repeat split.
  all: assumption.
Qed.

(* PoS Anti-Symmetry *)
Theorem pos_antisym : forall s t,
  PoS s t /\ PoS t s -> s = t.
Proof.
  intros s t [[u Cstu][v Ctsv]].
  pose proof (composition_same_owner s t u Cstu) as [w [Pssw Pstw]].
  pose proof (single_occupancy s w Pssw) as [a [_ UniqueFs]].
  pose proof (single_occupancy t w Pstw) as [b [_ UniqueFt]].
  clear Pssw Pstw w.

  pose proof (composition_same_filler s t u Cstu) as [a1 [Fas Fau]].
  pose proof (composition_constraints s v t Ctsv) as [a2 [Fa2s Psva]].
  apply UniqueFs in Fas as a_eq_a1, Fa2s as a_eq_a2.
  rewrite <- a_eq_a1 in Fas, Fau.
  rewrite <- a_eq_a2 in Psva.
  clear UniqueFs a_eq_a1 a1 a_eq_a2 Fa2s a2.

  pose proof (composition_same_filler t s v Ctsv) as [b1 [Fbt Fbv]].
  pose proof (composition_constraints t u s Cstu) as [b2 [Fb2t Psub]].
  apply UniqueFt in Fbt as b_eq_b1, Fb2t as b_eq_b2.
  rewrite <- b_eq_b1 in Fbt, Fbv.
  rewrite <- b_eq_b2 in Psub.
  clear UniqueFt Fbt b_eq_b1 b1 b_eq_b2 Fb2t b2 .

  pose proof (mutual_occupancy a b u v (conj (conj Psub Fau) (conj Psva Fbv))) as a_eq_b.
  rewrite <- a_eq_b in Fbv, Psub.
  clear b a_eq_b .

  pose proof (unique_improper_slot a u v Psub Fau Psva Fbv) as u_eq_v.
  rewrite <- u_eq_v in Ctsv, Psva, Fbv.
  rename Ctsv into Ctsu.
  rename Psva into Psua.
  clear v u_eq_v Psub Fbv.

  pose proof (pro_imp_composition u s a (conj (conj Psua Fau) Fas)) as Cssu.
  pose proof (composition_unicity s u s t (conj Cssu Ctsu)); assumption.
Qed.

(* PoS Transitivity *)
Theorem pos_trans : forall s t u,
  PoS s t /\ PoS t u -> PoS s u.
Proof.
  intros s t u [[v Cstv][w Ctuw]]; move w before v.
  unfold PoS.
  (* Owner of s, t and u *)
  pose proof (composition_same_owner s t v Cstv) as [a1 [Pssa1 Psta1]]; move a1 before w.
  pose proof (composition_same_owner t u w Ctuw) as [a2 [Psta2 Psua2]]; move a2 before a1.
  pose proof (single_owner t a1 Psta1) as UniquePsa.
  apply UniquePsa in Psta2 as a_eq_a2.
  rewrite <- a_eq_a2 in Psua2.
  rename a1 into a, Pssa1 into Pssa, Psua2 into Psua, Psta1 into Psta.
  clear a_eq_a2 a2 Psta2 UniquePsa.
  (* Fillers of s, t and u *)
  pose proof (single_occupancy s a Pssa) as [d [Fds UniqueFs]]; move d before a.
  pose proof (single_occupancy t a Psta) as [c [Fct UniqueFt]]; move c before a.
  pose proof (single_occupancy u a Psua) as [b [Fbu UniqueFu]]; move b before a.
  (* Fillers of v and w *)
  pose proof (composition_same_filler s t v Cstv) as [d' [d_eq_d' Fdv]].
  apply UniqueFs in d_eq_d'.
  rewrite <- d_eq_d' in Fdv.
  clear d' d_eq_d'.
  pose proof (composition_same_filler t u w Ctuw) as [c' [c_eq_c' Fcw]].
  apply UniqueFt in c_eq_c'.
  rewrite <- c_eq_c' in Fcw.
  clear c' c_eq_c'.
  (* *)
  pose proof (composition_constraints t v s Cstv) as [c' [c_eq_c' Psvc]].
  apply UniqueFt in c_eq_c'.
  rewrite <- c_eq_c' in Psvc.
  clear c_eq_c' c'.
  pose proof (composition_constraints u w t Ctuw) as [b' [b_eq_b' Pswb]].
  apply UniqueFu in b_eq_b'.
  rewrite <- b_eq_b' in Pswb.
  clear b_eq_b' b'.
  (* *)
  pose proof (composition_existence w v c (conj Fcw Psvc)) as [y Cywv]; move y before w.
  pose proof (composition_same_owner y w v Cywv) as [b' [Psyb b_eq_b']].
  pose proof (single_owner w b Pswb) as UniquePsw.
  apply UniquePsw in b_eq_b'.
  rewrite <- b_eq_b' in Psyb.
  clear UniquePsw b_eq_b' b'.
  (* *)
  exists y.
  pose proof (composition_existence u y b (conj Fbu Psyb)) as [s' Cs'uy].
  pose proof (composition_associativity u w v t s y s' (conj (conj Ctuw Cstv) (conj Cs'uy Cywv))) as s_eq_s'.
  rewrite <- s_eq_s' in Cs'uy.
  assumption.
Qed.

Theorem slots_are_parts_of_imp_slot :
  forall s t x, IPs s x -> Ps t x -> PoS t s.
Proof.
  intros s t x H.
  unfold PoS.
  exists t.
  apply imp_pro_composition with (x:=x).
  split; assumption.
Qed.

Theorem pos_same_owner :
  forall s t, PoS s t -> exists x, Ps s x /\ Ps t x.
Proof.
  intros s t [u Cstu].
  apply composition_same_owner with (u:=s) (s:=t) (t:=u).
  assumption.
Qed.

(* *)
Theorem slots_constrain_fillers : forall a b s t,
  F b t /\ F a s /\ PoS t s -> P b a.
Proof.
  intros a b s t [Fbt [Fas [u Ctsu]]].
  pose proof (composition_constraints s u t Ctsu) as [a' [H H0]].
  pose proof (composition_same_owner t s u Ctsu) as [z [Pstz Pssz]].
  pose proof (single_occupancy s z Pssz) as [a'' [H1 H2]].
  apply H2 in Fas as a''_eq_a, H as a''_eq_a'.
  rewrite a''_eq_a in a''_eq_a'.
  rewrite <- a''_eq_a' in H0.
  clear a''_eq_a a''_eq_a' H1 H2 H a'' a'.
  pose proof (composition_same_filler t s u Ctsu) as [x [H H1]].
  pose proof (single_occupancy t z Pstz) as [x0 [H2 H3]].
  apply H3 in Fbt as x0_eq_b, H as x0_eq_x.
  rewrite x0_eq_x in x0_eq_b.
  rewrite x0_eq_b in H1.
  clear H2 H3 x0_eq_b x0_eq_x H.
  unfold P.
  exists u.
  split; assumption.
Qed.

(* *)
Theorem fillers_constrain_slots : forall a b,
  (P b a -> exists s t, (F b t /\ F a s /\ PoS t s)).
Proof.
  intros a b [t []].
  pose proof (whole_improper_slots a).
  destruct H1 as [s []].
  exists t; assumption.
  exists s, t.
  repeat split; try assumption.
  unfold PoS.
  exists t.
  apply imp_pro_composition with (x:=a).
  unfold IPs.
  repeat split; assumption.
Qed.

(********************
 * Overlap of Slots *
 ********************)

Definition OoS s t := exists u, PoS u s /\ PoS u t.

(* Conditional OoS Reflexivity *)
Theorem cond_oos_refl : forall s x,
  Ps s x -> OoS s s.
Proof.
  intros s x Pssx.
  unfold OoS.
  exists s.
  apply conditional_pos_refl in Pssx.
  split; assumption.
Qed.

(* OoS Symmetry *)
Theorem oos_symmetry : forall s t,
  OoS s t -> OoS t s.
Proof.
  unfold OoS.
  intros.
  destruct H as [x H].
  exists x.
  apply and_comm.
  assumption.
Qed.

(* OoS Same Owner *)
Theorem oos_same_owner : forall s t,
  OoS s t -> (exists x, Ps s x /\ Ps t x).
Proof.
  intros s t [x [PoSxs PoSxt]].
  apply pos_same_owner in PoSxs as [sOwner []].
  apply pos_same_owner in PoSxt as [tOwner []].
  pose proof (single_owner x sOwner H).
  apply H3 in H1.
  rewrite <- H1 in H2.
  exists sOwner.
  split; assumption.
Qed.

Theorem oos_pseudo_trans:
  forall s t u, OoS u t /\ PoS t s -> OoS u s.
Proof.
  unfold OoS.
  intros s t u [[v [PoSvu PoSvt]] PoSts].
  pose proof (pos_trans v t s (conj PoSvt PoSts)).
  exists v.
  split; assumption.
Qed.

Theorem slots_overlap_with_imp_slot :
  forall s t x, IPs s x /\ Ps t x -> OoS s t.
Proof.
  intros s t x [IPssx Pstx].
  unfold OoS, PoS.
  exists t.
  split.
  - exists t.
    apply imp_pro_composition with (x:=x).
    split; assumption.
  - pose proof (single_occupancy t x Pstx) as [y [Fyt _]].
    pose proof (A3 y t Fyt) as [u IPsuy].
    exists u.
    apply pro_imp_composition with (x:=y).
    split; assumption.
Qed.

(****************
 * Sum of Slots *
 ****************)

Definition SoS u s t := forall v,
  ((OoS u v) <-> (OoS s v \/ OoS t v)).

(* Sum Existence *)
Axiom sum_existence : forall s t,
  (exists x, (Ps s x /\ Ps t x)) -> (exists u, (SoS u s t)).

(* Sum Unicity *)
Axiom sum_unicity : forall s t u v,
  (SoS u s t /\ SoS v s t -> u = v).

(* Sum Commutativity *)
Theorem sum_commutativity : forall s t u,
  SoS u s t <-> SoS u t s.
Proof.
  intros s t u.
  unfold SoS.
  setoid_rewrite (or_comm (OoS s _)).
  reflexivity.
Qed.

(* Sum Associativity *)
Theorem sum_associativity : forall s t u a b c d,
  ((SoS a s t /\ SoS b a u) /\ (SoS d s c /\ SoS c t u) -> b = d).
Proof.
  intros s t u a b c d.
  unfold SoS.
  intros [[][]].
  apply sum_unicity with (s:=s) (t:=c).
  unfold SoS.
  setoid_rewrite H0.
  setoid_rewrite H.
  setoid_rewrite H1.
  setoid_rewrite H2.
  intuition.
Qed.

(* Sum Idempotence *)
Theorem sum_idempotence : forall s, SoS s s s.
Proof.
  intros s v.
  split; intro.
  - left; assumption.
  - destruct H; assumption.
Qed.

Theorem sum_imp_slot :
  forall s t x, IPs s x /\ Ps t x -> SoS s s t.
Proof.
  intros s t x [].
  unfold SoS.
  intros v.
  split.
  - intro OoSsv.
    left; assumption.
  - intros.
    destruct H1.
    + assumption.
    + pose proof (oos_same_owner t v H1) as [].
      apply slots_overlap_with_imp_slot with (x:=x).
      split.
      * assumption.
      * destruct H2.
        pose proof (single_owner t x H0).
        apply H4 in H2 as H5.
        rewrite H5.
        assumption.
Qed.

(* Sum Same Owner *)
Theorem sum_same_owner : forall s t u,
  (SoS u s t -> exists x, (Ps u x /\ Ps s x /\ Ps t x)).
Proof.
  intros s t u.
  unfold SoS.
  intros [].
Admitted.

(***********************
 * Composition And Sum *
 ***********************)

Theorem comp_sum_same_owner : forall a b c s t u x,
  Ps s x -> C a s t -> C b s u -> SoS c a b -> Ps c x.
Proof.
  intros.
  pose proof (composition_same_owner a s t H0) as [x0 []].
  pose proof (sum_same_owner a b c H2) as [x1 [H5 []]].
  pose proof (single_owner s x H).
  apply H8 in H4.
  rewrite <- H4 in H3.
  pose proof (single_owner a x H3).
  apply H9 in H6.
  rewrite <- H6 in H5, H7.
  assumption.
Qed.

Theorem improper_left_distributivity: forall x s t u a b c d e,
  IPs s x -> SoS a t u -> C b s a -> C c s t -> C d s u -> SoS e c d -> b = e.
Proof.
  intros x s t u a b c d e [Pssx Fxs] SoSatu Cbsa Ccst Cdsu SoSecd.
  pose proof (composition_constraints s t c Ccst) as [x0 []].
  pose proof (single_occupancy s x Pssx) as [x1 [_ UniqueFs]].
  apply UniqueFs in Fxs as x1_eq_x.
  apply UniqueFs in H.
  rewrite <- H in H0.
  rewrite x1_eq_x in H0.
  clear UniqueFs H x1_eq_x x1 x0.
  pose proof (sum_same_owner t u a SoSatu) as [x0 [H []]].
  pose proof (single_owner t x H0).
  apply H3 in H1.
  rewrite <- H1 in H, H2.
  clear H1 H3 x0.
  pose proof (imp_pro_composition s a x (conj (conj Pssx Fxs) H)) as Casa.
  pose proof (composition_unicity s a b a (conj Cbsa Casa)).
  rewrite H1.
  clear H1 Cbsa b.
  pose proof (imp_pro_composition s t x (conj (conj Pssx Fxs) H0)) as Ctst.
  pose proof (composition_unicity s t c t (conj Ccst Ctst)).
  rewrite H1 in SoSecd.
  clear H1 Ccst c.
  pose proof (imp_pro_composition s u x (conj (conj Pssx Fxs) H2)) as Cusu.
  pose proof (composition_unicity s u d u (conj Cdsu Cusu)).
  rewrite H1 in SoSecd.
  clear H1 Cdsu d.
  pose proof (sum_unicity t u a e (conj SoSatu SoSecd)).
  assumption.
Qed.

Theorem left_distributivity: forall s t u a b c d e,
  SoS a t u -> C b s a -> C c s t -> C d s u -> SoS e c d -> b = e.
Proof.
  intros s t u a b c d e Satu Cbsa Ccst Cdsu Secd.
  unfold SoS in Satu, Secd.
  unfold OoS in Satu, Secd.
  unfold PoS in Satu, Secd.
Admitted.

(*******************
 * Supplementation *
 *******************)

Theorem full_overlap_is_identity:
  forall s t, (forall u, OoS s u <-> OoS t u) -> s = t.
Proof.
  intros s t H.
  apply sum_unicity with (s:=s) (t:=t).
  split; intros v; rewrite H; intuition.
Qed.

Lemma at_least_two_proper_slots : forall s t x,
  IPs s x -> PPs t x -> (forall v, PPs v x -> t = v) -> forall u, OoS s u <-> OoS t u.
Proof.
  intros s t x [Pssx Fxs] [Pstx nFxt] UniquePPsx u.
  split.
  2: {
    intros.
    apply oos_symmetry.
    apply oos_symmetry in H.
    apply oos_pseudo_trans with (s:=s) (t:=t) (u:=u).
    split.
    + assumption.
    + apply slots_are_parts_of_imp_slot with (x:=x).
      repeat split; assumption.
      assumption.
  }
  - intros.
    unfold OoS.
    destruct H as [v []].
    exists v.
    split; try assumption.
    pose proof (pos_same_owner v s H) as [x0 []].
    pose proof (single_owner s x Pssx).
    apply H3 in H2.
    rewrite <- H2 in H1.
    clear H2 H3.
    pose proof (either_proper_or_improper v x H1).
    destruct H2.
    + destruct  H2.
      apply UniquePPsx in H2.
      rewrite <- H2.
      apply conditional_pos_refl with (x:=x).
      assumption.
    + destruct H2.
      destruct H3.
      pose proof (unique_improper_slot x s v Pssx Fxs H3 H4).
      rewrite <- H5 in *.
      clear H5 v.
      pose proof (slots_are_parts_of_imp_slot s t x (conj Pssx Fxs) Pstx).
Abort.

Theorem slot_company:
  forall s x, PPs s x -> exists t, PPs t x /\ s <> t.
Proof.
  intros s x [Pssx nFxs].
  pose proof (whole_improper_slots x) as [Sx [PsSxx FxSx]].
  exists s; assumption.
Admitted.

Theorem slot_weak_supplementation :
  forall s x, PPs s x -> exists t, Ps t x /\ ~ (OoS s t).
Proof.
  intros s x PPsx.
Admitted.


Require NPeano.
Import NPeano.Nat.
Require Import ExtLib.Tactics.Consider.
Require Import Coq.Bool.Bool.
Require Import ExtLib.Data.Nat.

Require Import Coq.ZArith.ZArith.

Set Implicit Arguments.
Set Strict Implicit.

(**  Some tests *)
Section test.
  Goal forall x y z,  (ltb x y && ltb y z) = true ->
                 ltb x z = true.
  intros x y z.
  consider (ltb x y && ltb y z).
  consider (ltb x z); auto. intros. exfalso. omega.
  Qed.

  Goal forall x y z,
    ltb x y = true ->
    ltb y z = true ->
    ltb x z = true.
  Proof.
    intros. consider (ltb x y); consider (ltb y z); consider (ltb x z); intros; auto.
    exfalso; omega.
  Qed.

End test.


Require Export int_auto.
Require Export math_sol.
Require Export math_rewrite.
(*
Require Import Coqlib.
Require Import Integers.
Require Import ZArith.
Require Import LibTactics.

Open Scope Z_scope.

(** * Frequently used lemmas in tactics. *)

Lemma min_signed_lt0 : Int.min_signed < 0.
Proof.
  unfold Int.min_signed, Int.half_modulus, Int.modulus.
  simpl; omega.
Qed.

Lemma max_signed_gt0 : Int.max_signed > 0.
Proof.
  unfold Int.max_signed, Int.half_modulus, Int.modulus.
  simpl; omega.
Qed.

Lemma zdiv_equiv: forall x y : Z, x >= 0 -> y > 0 -> x ÷ y = x / y.
Proof.
  intros.
  rewrite Int.Zquot_Zdiv.
  destruct (zlt x 0).
  omega.
  trivial.
  assumption.
Qed.

Lemma zadd_rm_head: forall n p q, p = q -> n + p = n + q.
Proof.
  intros.
  rewrite H.
  trivial.
Qed.

Lemma zadd_rm_tail: forall n p q, p = q -> p + n = q + n.
Proof.
  intros.
  rewrite H.
  trivial.
Qed.

Lemma zdiv_range_le_lt : forall a b c x: Z, a <= 0 -> b > 0 -> c > 0 -> a <= x < b -> a <= x/ c < b.
Proof.
  intros.
  destruct H2.
  split.
  apply Zdiv_le_lower_bound.
  omega.
  assert(a * c <= a).
  assert(- a * c >= - a).
  rewrite <- Zmult_1_r.
  assert(c >= 1) by omega.
  apply Zmult_ge_compat_l.
  omega.
  omega.
  rewrite Zopp_mult_distr_l_reverse in H4.
  omega.
  omega.
  apply Zdiv_lt_upper_bound.
  omega.
  assert(b <= b * c).
  rewrite <- Zmult_1_r at 1.
  assert(1 <= c) by omega.
  apply Zmult_le_compat_l.
  omega.
  omega.
  omega.
Qed.

Lemma zdiv_range_le_le : forall a b c x: Z, a <= 0 -> b > 0 -> c > 0 -> a <= x <= b -> a <= x/ c <= b.
Proof.
  intros.
  destruct H2.
  split.
  apply Zdiv_le_lower_bound.
  omega.
  assert(a * c <= a).
  assert(- a * c >= - a).
  rewrite <- Zmult_1_r.
  assert(c >= 1) by omega.
  apply Zmult_ge_compat_l.
  omega.
  omega.
  rewrite Zopp_mult_distr_l_reverse in H4.
  omega.
  omega.
  apply Zdiv_le_upper_bound.
  omega.
  assert(b <= b * c).
  rewrite <- Zmult_1_r at 1.
  assert(1 <= c) by omega.
  apply Zmult_le_compat_l.
  omega.
  omega.
  omega.
Qed.

Lemma max_unsigned_gt0: Int.max_unsigned > 0.
Proof.
  unfold Int.max_unsigned, Int.modulus.
  simpl; omega.
Qed.

Lemma max_unsigned_val: Int.max_unsigned  = 4294967295.
Proof.
  unfold Int.max_unsigned, Int.modulus.
  simpl; omega.
Qed.

Lemma max_signed_val : Int.max_signed = 2147483647.
Proof.
  unfold Int.max_signed, Int.half_modulus, Int.modulus.
  simpl; omega.
Qed.

Lemma min_signed_val : Int.min_signed = -2147483648.
Proof.
  unfold Int.min_signed, Int.half_modulus, Int.modulus.
  simpl; omega.
Qed.

Lemma unsigned_mone_val : Int.unsigned Int.mone = 4294967295.
Proof.
  rewrite Int.unsigned_mone.
  simpl; auto.
Qed.

Lemma modulus_val : Int.modulus = 4294967296.
Proof.
  unfold Int.modulus.
  simpl; auto.
Qed.

Lemma unsigned_inj : forall a b, Int.unsigned a = Int.unsigned b -> a = b.
Proof.
  intros. rewrite <- (Int.repr_unsigned a).
  rewrite <- (Int.repr_unsigned b).
  f_equal.
  trivial.
Qed.

Lemma minus1lt: forall i:Z, i - 1 < i.
Proof.
  intro.
  omega.
Qed.

Lemma Z_land_range_lo: forall x y, 0 <= x -> 0 <= Z.land x y.
Proof.
  intros.
  rewrite Z.land_nonneg.
  left.
  assumption.
Qed.

Lemma Z_land_range_lo_r: forall x y, 0 <= y -> 0 <= Z.land x y.
Proof.
  intros.
  rewrite Z.land_nonneg.
  right.
  assumption.
Qed.

Lemma Z_land_range_hi: forall x y, 0 <= x <= Int.max_unsigned -> 0 <= y <= Int.max_unsigned -> Z.land x y <= Int.max_unsigned.
Proof.
  rewrite max_unsigned_val.
  intros.
  assert(Z.land x y < 4294967296).
  apply Z.log2_lt_cancel.
  assert(Z.log2 (Z.land x y) <= Z.min (Z.log2 x) (Z.log2 y)).
  apply Z.log2_land.
  omega.
  omega.
  rewrite Zmin_spec in H1.
  destruct (zlt (Z.log2 x) (Z.log2 y)).
  assert(Z.log2 x <= Z.log2 4294967295).
  apply Z.log2_le_mono.
  omega.
  simpl in *.
  omega.
  assert(Z.log2 y <= Z.log2 4294967295).
  apply Z.log2_le_mono.
  omega.
  simpl in *.
  omega.
  omega.
Qed.

Lemma Z_land_range: forall x y, 0 <= x <= Int.max_unsigned -> 0 <= y <= Int.max_unsigned -> 0 <= Z.land x y <= Int.max_unsigned.
Proof.
  split.
  apply Z_land_range_lo; omega.
  apply Z_land_range_hi; omega.
Qed.

Lemma Z_lor_range_lo: forall x y, 0 <= x -> 0 <= y -> 0 <= Z.lor x y.
Proof.
  intros.
  apply Z.lor_nonneg; auto.
Qed.

Lemma Z_lor_range_hi: forall x y, 0 <= x <= Int.max_unsigned -> 0 <= y <= Int.max_unsigned -> Z.lor x y <= Int.max_unsigned.
Proof.
  rewrite max_unsigned_val; simpl.
  intros.
  assert(Z.lor x y < 4294967296).
  apply Z.log2_lt_cancel.
  assert(Z.log2 (Z.lor x y) = Z.max (Z.log2 x) (Z.log2 y)).
  apply Z.log2_lor.
  omega.
  omega.
  rewrite H1.
  rewrite Zmax_spec in *.
  destruct (zlt (Z.log2 y) (Z.log2 x)).
  assert(Z.log2 x <= Z.log2 4294967295).
  apply Z.log2_le_mono.
  omega.
  simpl in *.
  omega.
  assert(Z.log2 y <= Z.log2 4294967295).
  apply Z.log2_le_mono.
  omega.
  simpl in *.
  omega.
  omega.
Qed.

Lemma Z_lor_range: forall x y, 0 <= x <= Int.max_unsigned -> 0 <= y <= Int.max_unsigned -> 0 <= Z.lor x y <= Int.max_unsigned.
Proof.
  intros.
  split.
  apply Z_lor_range_lo; omega.
  apply Z_lor_range_hi; omega.
Qed.

Lemma Z_lxor_range :
  forall x y,
    0 <= x <= Int.max_unsigned -> 0 <= y <= Int.max_unsigned ->
    0 <= Z.lxor x y <= Int.max_unsigned.
Proof.
  rewrite max_unsigned_val; simpl.
  intros.
  split.
  rewrite Z.lxor_nonneg.
  split; omega.
  assert(Z.lxor x y < 4294967296).
  apply Z.log2_lt_cancel.
  assert(Z.log2 (Z.lxor x y) <= Z.max (Z.log2 x) (Z.log2 y)).
  apply Z.log2_lxor.
  omega.
  omega.
  apply Z.le_lt_trans with (m := Z.max (Z.log2 x) (Z.log2 y)); auto.
  rewrite Zmax_spec in *.
  destruct (zlt (Z.log2 y) (Z.log2 x)).
  assert(Z.log2 x <= Z.log2 4294967295).
  apply Z.log2_le_mono.
  omega.
  simpl in *.
  omega.
  assert(Z.log2 y <= Z.log2 4294967295).
  apply Z.log2_le_mono.
  omega.
  simpl in *.
  omega.
  omega.
Qed.

Lemma Z_shiftl_16_range :
  forall x,
    0 <= x < 65536 -> 0 <= Z.shiftl x 16 <= Int.max_unsigned.
Proof.
  unfold Int.max_unsigned. simpl (Int.modulus - 1).
  intros.
  split.
  rewrite Z.shiftl_nonneg. omega.

  assert (Z.shiftl x 16 < 4294967296).
  case_eq (zeq x 0); intros; subst.

  (* x = 0 *)
  simpl. omega.

  (* x <> 0 *)
  apply Z.log2_lt_cancel.
  rewrite Z.log2_shiftl; try omega.

  assert (Z.log2 x <= Z.log2 65535).
  apply Z.log2_le_mono. omega.
  simpl in *. omega.

  omega.
Qed.

(** * Hints for autorewrite *)

Lemma unsigned_zero: Int.unsigned Int.zero = 0.
Proof. reflexivity. Qed.

Lemma unsigned_one: Int.unsigned Int.one = 1.
Proof. reflexivity. Qed.

Lemma eq_one_zero: Int.eq Int.one Int.zero = false.
Proof. reflexivity. Qed.

Lemma eq_zero_zero: Int.eq Int.zero Int.zero = true.
Proof. reflexivity. Qed.

Lemma negb_true: negb true = false.
Proof. reflexivity. Qed.

Lemma negb_false: negb false = true.
Proof. reflexivity. Qed.

Lemma repr_zero: Int.repr 0 = Int.zero.
Proof. reflexivity. Qed.

Lemma repr_one: Int.repr 1 = Int.one.
Proof. reflexivity. Qed.

Lemma and_zero_zero: Z.land 0 0 = 0.
Proof. reflexivity. Qed.

Lemma and_one_zero: Z.land 1 0 = 0.
Proof. reflexivity. Qed.

Lemma and_zero_one: Z.land 0 1 = 0.
Proof. reflexivity. Qed.

Lemma and_one_one: Z.land 1 1 = 1.
Proof. reflexivity. Qed.

Lemma or_zero_zero: Z.lor 0 0 = 0.
Proof. reflexivity. Qed.

Lemma or_one_zero: Z.lor 1 0 = 1.
Proof. reflexivity. Qed.

Lemma or_zero_one: Z.lor 0 1 = 1.
Proof. reflexivity. Qed.

Lemma or_one_one: Z.lor 1 1 = 1.
Proof. reflexivity. Qed.

Hint Rewrite unsigned_zero unsigned_one eq_one_zero eq_zero_zero negb_true negb_false repr_zero repr_one: arith.
Hint Rewrite and_zero_zero and_zero_one and_one_zero and_one_one or_zero_zero or_zero_one or_one_zero or_one_one : arith.

(** * Auxiliary tactics used by other main tactics below. *)
(* Check svn version before 1408 *)

Ltac simpleproof := match goal with
                      | [|- _ <= _] => tryfalse || assumption || omega || trivial || eassumption || auto || idtac
                      | _ => tryfalse || assumption || omega || trivial || reflexivity || eassumption || auto || idtac
                    end.

Ltac autorewritearith := autorewrite with arith using simpleproof.

Ltac solve_signed_range c x:=
  assert(cge0: c > 0) by omega;
  generalize(zdiv_range_le_le Int.min_signed Int.max_signed c (Int.signed x) min_signed_lt0 max_signed_gt0 cge0 (Int.signed_range x));
  omega; clear cge0.

Ltac solve_unsigned_range c x :=
  assert(cge0: c > 0) by omega;
  assert(zlez: 0 <= 0) by omega;
  generalize(zdiv_range_le_le 0 Int.max_unsigned c (Int.unsigned x) zlez max_unsigned_gt0 cge0 (Int.unsigned_range_2 x));
  omega; clear cge0 zlez.

Ltac solve_unsigned_range_lt c x :=
  assert(cge0: c > 0) by omega;
  assert(zlez: 0 <= 0) by omega;
  assert(xpre: 0 <= x < Int.max_unsigned) by omega;
  generalize(zdiv_range_le_lt 0 Int.max_unsigned c x zlez max_unsigned_gt0 cge0 xpre);
  omega; clear cge0 zlez xpre.

Ltac computedivmul :=
  match goal with
    | [|- context [?x / ?y]] => let val := eval compute in (x / y) in change (x / y) with val
    | [|- context [?x * ?y]] => let val := eval compute in (x * y) in change (x * y) with val
  end.

(** * The tactic to prove the integers fit in signed range or unsigned range. *)

Ltac gen_signed_unsigned_range e :=
  let H := fresh in
  match e with
    | ?e1 + ?e2 => gen_signed_unsigned_range e1; gen_signed_unsigned_range e2
    | ?e1 - ?e2 => gen_signed_unsigned_range e1; gen_signed_unsigned_range e2
    | ?e1 * ?e2 => gen_signed_unsigned_range e1; gen_signed_unsigned_range e2
    | ?e1 / ?e2 => gen_signed_unsigned_range e1; gen_signed_unsigned_range e2
    | context [ Int.signed ?i ] =>
      generalize (Int.signed_range i);
        intros H; rewrite max_signed_val in H; rewrite min_signed_val in H
    | context [ Int.unsigned ?i ] =>
      generalize (Int.unsigned_range i);
        intros H; rewrite modulus_val in H
    | _ => idtac
  end.

Ltac solve_int_unequal :=
  match goal with
    | H: _ /\ _ |- _=> destruct H; solve_int_unequal
    | |- _ /\ _ => split; solve_int_unequal
    | |- ?e1 <= ?e2 => gen_signed_unsigned_range e1; gen_signed_unsigned_range e2; try omega
    | |- ?e1 < ?e2 => gen_signed_unsigned_range e1; gen_signed_unsigned_range e2; try omega
    | |- ?e1 >= ?e2 => gen_signed_unsigned_range e1; gen_signed_unsigned_range e2; try omega
    | |- ?e1 > ?e2 => gen_signed_unsigned_range e1; gen_signed_unsigned_range e2; try omega
    | |- Int.min_signed <= Int.signed ?x / ?c =>
      solve_signed_range c x
    | |- Int.min_signed <= ?x / ?c =>
      rewrite <- Int.signed_repr with (z:= x); solve_signed_range c (Int.repr x)
    | |- Int.signed ?x / ?c <= Int.max_signed =>
      solve_signed_range c x
    | |- ?x / ?c <= Int.max_signed =>
      rewrite <- Int.signed_repr with (z:= x); solve_signed_range c (Int.repr x)
    | |- 0 <= Int.unsigned ?x / ?c => solve_unsigned_range c x
    | |- 0 <= ?x / ?c => rewrite <- Int.unsigned_repr with (z:= x); solve_unsigned_range c (Int.repr x)
    | |- 0 <= ?x / ?c + 1 => rewrite <- Int.unsigned_repr with (z:= x); solve_unsigned_range c (Int.repr x)
    | |- Int.unsigned ?x / ?c <= Int.max_unsigned => solve_unsigned_range c x
    | |- ?x / ?c <= Int.max_unsigned => rewrite <- Int.unsigned_repr with (z:= x); solve_unsigned_range c (Int.repr x)
    | |- ?x / ?c + 1 <= Int.max_unsigned => solve_unsigned_range_lt c x
    | |- ?x / ?y * ?c => try (computedivmul; omega)
    | _ => idtac
  end.

Ltac unsigned_range :=
  match goal with
   | [|- 0 <= ?af] =>
      match af with
        | Z.shiftl _ _ => simpl; try omega
        | Z.shiftr _ _ => simpl; try omega
        | Z.land ?x ?y => apply Z_land_range_lo; try (simpl; omega)
        | Z.lor ?x ?y => apply Z_lor_range_lo; try (simpl; omega)
        | _ => try omega
      end
    | [|- ?af <= Int.max_unsigned] =>
      match af with
        | Z.shiftl _ _ => simpl; try omega
        | Z.shiftr _ _ => simpl; try omega
        | Z.land ?x ?y => apply Z_land_range_hi; try (simpl; omega)
        | Z.lor ?x ?y => apply Z_lor_range_hi; try (simpl; omega)
        | _ => repeat rewrite max_unsigned_val; try omega
      end
  end.

Ltac int_auto_simpl :=
  match goal with
    | H: _ /\ _ |- _ => destruct H; int_auto_simpl

    | H: context [Int.signed Int.zero] |- _ => change (Int.signed Int.zero) with 0 in H; int_auto_simpl
    | |- context [Int.signed Int.zero] => change (Int.signed Int.zero) with 0; int_auto_simpl
    | H: context [Int.signed Int.one] |- _ => change (Int.signed Int.one) with 1 in H; int_auto_simpl
    | |- context [Int.signed Int.one] => change (Int.signed Int.one) with 1; int_auto_simpl

    | H: context [Int.unsigned Int.zero] |- _ => change (Int.unsigned Int.zero) with 0 in H; int_auto_simpl
    | |- context [Int.unsigned Int.zero] => change (Int.unsigned Int.zero) with 0; int_auto_simpl
    | H: context [Int.unsigned Int.one] |- _ => change (Int.unsigned Int.one) with 1 in H; int_auto_simpl
    | |- context [Int.unsigned Int.one] => change (Int.unsigned Int.one) with 1; int_auto_simpl
    | H: context [Int.unsigned Int.mone] |- _ => rewrite unsigned_mone_val in H; int_auto_simpl
    | |- context [Int.unsigned Int.mone] => rewrite unsigned_mone_val; int_auto_simpl

    | H: context [Int.eq ?x ?x] |- _ => rewrite Int.eq_true in H; int_auto_simpl
    | |- context [Int.eq ?x ?x] => rewrite Int.eq_true; int_auto_simpl
    | H: context [Int.eq Int.one Int.zero] |- _ => change (Int.eq Int.one Int.zero) with false in H; int_auto_simpl
    | |- context [Int.eq Int.one Int.zero] => change (Int.eq Int.one Int.zero) with false; int_auto_simpl

    | H: context [Int.and Int.zero _] |- _ => rewrite Int.and_zero_l in H; int_auto_simpl
    | |- context [Int.and Int.zero _] => rewrite Int.and_zero_l; int_auto_simpl
    | H: context [Int.and _ Int.zero] |- _ => rewrite Int.and_zero in H; int_auto_simpl
    | |- context [Int.and _ Int.zero] => rewrite Int.and_zero; int_auto_simpl

    | H: context [negb true] |- _ => change (negb true) with false in H; int_auto_simpl
    | |- context [negb true] => change (negb true) with false; int_auto_simpl
    | H: context [negb false] |- _ => change (negb false) with true in H; int_auto_simpl
    | |- context [negb false] => change (negb false) with true; int_auto_simpl

    | H: context [Int.repr (Int.signed _)] |- _ => rewrite Int.repr_signed in H; int_auto_simpl
    | |- context [Int.repr (Int.signed _)] => rewrite Int.repr_signed; int_auto_simpl
    | H: context [Int.repr (Int.unsigned _)] |- _ => rewrite Int.repr_unsigned in H; int_auto_simpl
    | |- context [Int.repr (Int.unsigned _)] => rewrite Int.repr_unsigned; int_auto_simpl

    | H: context [Int.signed (Int.repr _)] |- _ => rewrite Int.signed_repr in H; [ int_auto_simpl | rewrite min_signed_val, max_signed_val; try omega ]
    | H: context [Int.unsigned (Int.repr _)] |- _ => rewrite Int.unsigned_repr in H; [ int_auto_simpl | rewrite max_unsigned_val; try omega ]
    | |- context [Int.signed (Int.repr _)] => rewrite Int.signed_repr; [ int_auto_simpl | rewrite min_signed_val, max_signed_val; try omega ]
    | |- context [Int.unsigned (Int.repr _)] => rewrite Int.unsigned_repr; [ int_auto_simpl | rewrite max_unsigned_val; try omega ]

    | H: context [Int.min_signed] |- _ => rewrite min_signed_val in H; int_auto_simpl
    | |- context [Int.min_signed] => rewrite min_signed_val; int_auto_simpl
    | H: context [Int.max_signed] |- _ => rewrite max_signed_val in H; int_auto_simpl
    | |- context [Int.max_signed] => rewrite max_signed_val; int_auto_simpl
    | H: context [Int.max_unsigned] |- _ => rewrite max_unsigned_val in H; int_auto_simpl
    | |- context [Int.max_unsigned] => rewrite max_unsigned_val; int_auto_simpl

    | H: context [Int.cmpu] |- _ => unfold Int.cmpu in H; int_auto_simpl
    | H: context [Int.eq] |- _ => unfold Int.eq in H; int_auto_simpl
    | H: context [Int.ltu] |- _ => unfold Int.ltu in H; int_auto_simpl
    | H: context [Int.add] |- _ => unfold Int.add in H; int_auto_simpl
    | H: context [Int.sub] |- _ => unfold Int.sub in H; int_auto_simpl
    | H: context [Int.mul] |- _ => unfold Int.mul in H; int_auto_simpl
    | H: context [Int.divu] |- _ => unfold Int.divu in H; int_auto_simpl
    | H: context [Int.divs] |- _ => unfold Int.divs in H; int_auto_simpl
    | H: context [Int.and] |- _ => unfold Int.and in H; int_auto_simpl
    | H: context [Int.or] |- _ => unfold Int.or in H; int_auto_simpl
    | H: context [Int.xor] |- _ => unfold Int.xor in H; int_auto_simpl
    | H: context [Int.shl] |- _ => unfold Int.shl in H; int_auto_simpl
    | H: context [Int.shr] |- _ => unfold Int.shr in H; int_auto_simpl
    | H: context [Int.lt] |- _ => unfold Int.lt in H; int_auto_simpl
    | H: context [Int.modu] |- _ => unfold Int.modu in H; int_auto_simpl

    | |- context [Int.cmpu] => unfold Int.cmpu; int_auto_simpl
    | |- context [Int.eq] => unfold Int.eq; int_auto_simpl
    | |- context [Int.ltu] => unfold Int.ltu; int_auto_simpl
    | |- context [Int.add] => unfold Int.add; int_auto_simpl
    | |- context [Int.sub] => unfold Int.sub; int_auto_simpl
    | |- context [Int.mul] => unfold Int.mul; int_auto_simpl
    | |- context [Int.divu] => unfold Int.divu; int_auto_simpl
    | |- context [Int.divs] => unfold Int.divs; int_auto_simpl
    | |- context [Int.and] => unfold Int.and; int_auto_simpl
    | |- context [Int.or] => unfold Int.or; int_auto_simpl
    | |- context [Int.xor] => unfold Int.xor; int_auto_simpl
    | |- context [Int.shl] => unfold Int.shl; int_auto_simpl
    | |- context [Int.shr] => unfold Int.shr; int_auto_simpl
    | |- context [Int.lt] => unfold Int.lt; int_auto_simpl
    | |- context [Int.modu] => unfold Int.modu; int_auto_simpl

    | _ => repeat progress autorewritearith
  end.

Ltac int_auto_H :=
  int_auto_simpl;
  match goal with
    | H: context[Int.add] |- _ => rewrite Int.add_signed in H; int_auto_H
    | H: context[Int.sub] |- _ => rewrite Int.sub_signed in H; int_auto_H
    | H: context [Int.mul] |- _ => rewrite Int.mul_signed in H; int_auto_H
    | H: context [_ ÷ _] |- _ => rewrite zdiv_equiv in H; int_auto_H

    | H: context [zle ?z1 ?z2] |- _ => destruct (zle z1 z2); int_auto_H
    | H: context [zlt ?z1 ?z2] |- _ => destruct (zlt z1 z2); int_auto_H
    | H: context [zeq ?z1 ?z2] |- _ => destruct (zeq z1 z2); int_auto_H

    | _ => idtac
  end.

Ltac int_auto' :=
  match goal with
    | |- _ /\ _ => split; int_auto'
    | |- Int.repr _ = Int.repr _ => apply Int.eqm_samerepr; apply Int.eqm_refl2; int_auto'
    | |- Int.repr _ = _ => rewrite <- Int.repr_signed; apply Int.eqm_samerepr; apply Int.eqm_refl2; int_auto'
    | |- _ = Int.repr _ => rewrite <- Int.repr_signed; apply Int.eqm_samerepr; apply Int.eqm_refl2; int_auto'

    | |- context[Int.add] => rewrite Int.add_signed; int_auto'
    | |- context[Int.sub] => rewrite Int.sub_signed; int_auto'
    | |- context[Int.mul] => rewrite Int.mul_signed; int_auto'
    | |- context [_ ÷ _] => rewrite zdiv_equiv; int_auto'

    | |- context [zle ?z1 ?z2] => destruct (zle z1 z2); int_auto'
    | |- context [zlt ?z1 ?z2] => destruct (zlt z1 z2); int_auto'
    | |- context [zeq ?z1 ?z2] => destruct (zeq z1 z2); int_auto'

    | _ => solve_int_unequal || simpleproof
  end.

Ltac int_auto :=
  intros;
  int_auto_H;
  int_auto'.

Ltac int_auto ::=
     intros;
     int_auto_simpl;
  [ try solve [ simpleproof ];
    match goal with
      | |- _ /\ _ => split; int_auto
      | |- Int.repr _ = Int.repr _ => apply Int.eqm_samerepr; apply Int.eqm_refl2; int_auto
      | |- Int.repr _ = _ => try solve [ rewrite <- Int.repr_signed; apply Int.eqm_samerepr; apply Int.eqm_refl2; int_auto
                                       | rewrite <- Int.repr_unsigned; apply Int.eqm_samerepr; apply Int.eqm_refl2; int_auto ]
      | |- _ = Int.repr _ => try solve [ rewrite <- Int.repr_signed; apply Int.eqm_samerepr; apply Int.eqm_refl2; int_auto
                                       | rewrite <- Int.repr_unsigned; apply Int.eqm_samerepr; apply Int.eqm_refl2; int_auto ]
      | H: context [zle ?z1 ?z2] |- _ => destruct (zle z1 z2); int_auto
      | H: context [zlt ?z1 ?z2] |- _ => destruct (zlt z1 z2); int_auto
      | H: context [zeq ?z1 ?z2] |- _ => destruct (zeq z1 z2); int_auto
      | |- context [zle ?z1 ?z2] => destruct (zle z1 z2); int_auto
      | |- context [zlt ?z1 ?z2] => destruct (zlt z1 z2); int_auto
      | |- context [zeq ?z1 ?z2] => destruct (zeq z1 z2); int_auto
      | _ => solve_int_unequal
    end
  | idtac.. ].

Tactic Notation "int" "auto" := int_auto.

Goal
  forall z1 z2,
    0 < z1 < Int.max_signed ->
    0 < z2 < Int.max_signed ->
    z1 < z2 ->
    Int.sub (Int.add (Int.repr z1) (Int.sub (Int.repr z2) (Int.repr z1))) (Int.sub (Int.repr z2) (Int.repr z1)) = Int.repr z1.
Proof.
  int auto.
  int auto.
  int auto.
  int auto.
Qed.

Goal
  forall x y,
    Int.signed (Int.repr 1) < x < Int.signed (Int.repr 100) ->
    Int.signed (Int.repr 1) < y < Int.signed (Int.repr 100) ->
    Int.add (Int.repr x) (Int.repr y) = Int.repr (y + x).
Proof.
  int auto.
Qed.

Goal forall x y, 1 < x < Int.signed (Int.repr 100) -> 1 < y < 100
           -> Int.min_signed <= x + y <= Int.max_signed.
Proof.
  int auto.
Qed.

Goal forall x y,  0 < y < x -> x <= 1073741823 ->
                   Int.signed (Int.add (Int.repr x) (Int.repr y))  =  x + y.
 Proof.
   int auto.
   int auto.
 Qed.

Goal forall x, Int.ltu x (Int.repr 100) =true ->
               Int.ltu (Int.add x (Int.repr 10))(Int.repr 120) = true.
Proof.
  int auto.
  int auto.
Qed.

Goal forall x,
       Int.signed x < 100 ->
       Int.min_signed <= Int.signed x + 10 <= Int.max_signed.
Proof.
  int auto.
Qed.

Goal
  forall i1 i2,
    Int.ltu (Int.repr 0) i1 = true ->
    Int.ltu i2 (Int.repr Int.max_signed) = true ->
    Int.ltu i1 i2 = true ->
    Int.unsigned (Int.sub i1 i2) < 1  .
Proof.
  int auto.
  int auto.
Abort.

Goal
  forall i1 i2,
    Int.ltu Int.zero i1 = true ->
    Int.ltu i1 i2 = true ->
    Int.sub (Int.add i1 (Int.sub i2 i1)) (Int.sub i2 i1) = i1.
Proof.
  int auto.
  int auto.
  int auto.
  int auto.
Qed.

Set Implicit Arguments.
Unset Strict Implicit.

Require Import Integers.
Require Import Coq.Setoids.Setoid.
Require Import ZArith.
Require Import Arith.
Require Import LibTactics.

Module _mathsolver.

Fixpoint _iter {T:Type} (f:T->T) (base : T) (n: nat) : T :=
  match n with
      | O => base
      | S n' => _iter f (f base) n'
 end.
Module Type has_le.
  Parameter A: Type.
  Parameter le : A->A->Prop.

  Axiom le_refl : forall x:A, le x x.
  Axiom le_antisymm : forall a b:A, le a b -> le b a -> a=b.
  Axiom le_trans : forall a b c:A, le a b -> le b c -> le a c.
End has_le.

Module Type has_next (LE: has_le).
  Import LE.
  Parameter next : A->A.
  Axiom next_is_smallest : forall (x n:A), le x n <-> n =  x \/ le (next x) n.
End has_next.

Module Type has_dist (Import LE: has_le) (Import HN:has_next LE).
  Parameter dist : A->A->nat.
  Axiom dist_a : forall a b,le a b-> _iter next a (dist a b) = b.
End has_dist.

Module Range (Import LE: has_le) (Import HN : has_next LE) (Import HD: has_dist LE HN).
  Definition range (b:A)(l:nat)(x:A) := le b x /\ le x (_iter next b l).

  Lemma x_le_next: forall x :A , le x (next x).
    intros.
    rewrite next_is_smallest.
    right.
    apply le_refl.
  Qed.

  Lemma x_le_iter_next : forall (x :A) (n:nat), le x (_iter next x n).
    intros.
    generalize x; clear x.
    induction n.
    simpl.
    apply le_refl.
    simpl.
    intros.
    eapply (@le_trans _  (next x)).
    apply x_le_next.
    apply IHn.
  Qed.

  Lemma range_l_r: forall (l r x:A) , le l r -> (le l x /\ le x r <-> range l (dist l r) x).
    intros.
    split;
    intro;
    unfold range in *;
    rewrite dist_a in *;auto.
  Qed.

  Lemma range_split_first' : forall (b:A) (l:nat) (x:A), x=b \/ range (next b) l x -> range b (S l) x.
    intros b l.
    generalize b; clear b.
    induction l.
    intros.
    elim H; intros.
    unfold range.
    simpl.
    rewrite H0.
    split.
    apply le_refl.

    apply x_le_next.

    unfold range.
    unfold range in H0.
    unfold _iter in H0.
    unfold _iter.
    elim H0; intros.
    set (@le_antisymm x (next b) H2 H1 ).
    rewrite e.
    split.
    apply x_le_next.
    apply le_refl.

    intros.

    elim H; intros.
    rewrite H0; split; intros.
    apply le_refl.
    simpl.

    eapply (@le_trans _  (next (next b))).
    eapply (@le_trans _ (next b)).
    apply (x_le_next).
    apply x_le_next.
    apply x_le_iter_next.

    unfold range in *.
    elim H0; intros.
    split.
    eapply le_trans.
    Focus 2.
    exact H1.
    apply x_le_next.
    simpl.
    simpl in H2.
    exact H2.
  Qed.

  Lemma range_split_first'' : forall (b:A) (l:nat) (x:A), range b (S l) x -> x=b \/ range (next b) l x.
    intros.
    set (next_is_smallest b x).
    elim i; intros o o'.
    unfold range in H.
    inversion H.
    set (o H0).
    elim o0; intros.
    left; auto.
    right; unfold range.
    split; auto.
  Qed.

  Lemma range_split_first : forall (b:A) (l:nat) (x:A), range b (S l) x <-> x=b \/ range (next b) l x.
    split.
    apply range_split_first''.
    apply range_split_first'.
  Qed.

  Lemma range_eq : forall (l x:A), range l O x <-> x=l.
    split;intros.
    unfold range in H.
    elim H; intros.
    apply le_antisymm; auto.
    unfold range; rewrite H; split;apply le_refl.
  Qed.

  (* good *)
  Fixpoint gen_prop (b:A) (len:nat) (x:A) {struct len} :=
    match len with
      | O => x=b
      | S n => x = b \/ gen_prop (next b) n x
    end.

  (* bad *)
  Fixpoint gen_prop' (b:A) (len:nat) (x:A) {struct len} :=
    match len with
      | O => x=b
      | S n => gen_prop' b n x \/ x= _iter next b len
    end.

  Lemma range_fin_elem: forall b l x, range b l x <-> gen_prop b l x.
    intros b l.
    generalize b; clear b.
    induction l.
    intros; split; simpl;
    apply range_eq.

    intros; split; simpl; intros.
    apply range_split_first in H.
    elim H; intros.
    left; auto.
    right.
    apply IHl.
    auto.

    apply range_split_first.
    elim H; intros.
    left; auto.
    right; apply IHl.
    auto.
  Qed.
  Lemma range_l_r_fin_elem: forall (l r x:A) , le l r -> (le l x /\ le x r <-> gen_prop l (dist l r) x).
    intros.
    split.
    intro.
    rewrite range_l_r in H0.
    rewrite range_fin_elem in H0.
    auto.
    auto.
    intro.
    rewrite range_l_r; auto.
    rewrite range_fin_elem; auto.
  Qed.

  Lemma range_split_last'' : forall (b:A) (l:nat) (x:A), range b (S l) x -> range b l x \/ x= _iter next b (S l).
    intros b l.
    generalize b; clear b.
    induction l.
    intros.
    simpl.
    rewrite range_fin_elem in *.
    simpl in *.
    auto.
    intros.

    apply range_split_first in H.
    elim H; intros.
    left; rewrite H0.
    unfold range.
    split; auto.
    apply le_refl.
    apply x_le_iter_next.
    apply IHl in H0.
    elim H0; intros.
    left.

    unfold range.
    unfold range in H1.
    elim H1; intros.
    split.
    eapply le_trans.
    Focus 2.
    exact H2.
    apply x_le_next.
    simpl.
    exact H3.

    right.
    auto.
  Qed.

  Lemma range_split_last' : forall (b:A) (l:nat) (x:A), range b l x \/ x = _iter next b (S l) -> range b (S l) x.
    intros b l.
    generalize b; clear b.
    induction l.
    intros.
    rewrite range_fin_elem in *.
    simpl in *.
    auto.

    intros.
    elim H; intros.
    unfold range in H0.
    unfold range.
    elim H0; intros; split; auto.
    eapply le_trans.
    exact H2.
    Lemma iter_n_lt_lt: forall n b, le (_iter next b n) (_iter next b (S n)).
      intro.
      induction n.
      intros.
      simpl.
      apply x_le_next.

      intros.
      assert (forall k, _iter next b (S k) = _iter next (next b) k).
      auto.
      rewrite H.
      rewrite H.
      apply IHn.
    Qed.
    apply iter_n_lt_lt.
    unfold range.
    split.
    rewrite H0.
    apply x_le_iter_next.
    rewrite H0.
    apply le_refl.
  Qed.

  Lemma range_split_last : forall (b:A) (l:nat) (x:A), range b l x \/ x = _iter next b (S l) <-> range b (S l) x.
    intros.
    split.
    apply range_split_last'.
    apply range_split_last''.
  Qed.

  Lemma range_fin_elem2' : forall b len x, range b len x -> gen_prop' b len x.
    intros b l.
    generalize b; clear b.
    induction l.
    intros.
    simpl in *.
    apply range_eq.
    auto.

    intros.
    simpl.
    rewrite <- range_split_last in H.
    elim H; intros.
    left.
    apply IHl.
    auto.
    right.
    simpl in H0; auto.
  Qed.

  Lemma range_fin_elem2'': forall b len x, gen_prop' b len x -> range b len x.
    intros b l.
    generalize b; clear b.
    induction l;intros.
    simpl in H; apply range_eq.
    auto.

    rewrite<- range_split_last.
    simpl in H.
    elim H; intros.
    left; apply IHl; auto.
    right; simpl; auto.
  Qed.

  Lemma range_fin_elem2 : forall b len x, gen_prop' b len x <-> range b len x.
    intros.
    split.
    apply range_fin_elem2''.
    apply range_fin_elem2'.
  Qed.
End Range.

(* Z has le next and dist *)
Module Z_has_le <: has_le.
  Definition A := Z.
  Definition le := Zle.

  Definition le_refl:=Z.le_refl.
  Definition le_antisymm :=Z.le_antisymm.
  Definition le_trans := Z.le_trans.
End Z_has_le.

Module Z_has_next <: has_next Z_has_le.
  Definition next := fun x:Z => (1+ x)%Z.
  Lemma next_is_smallest: forall (x a:Z), Zle x a <-> a = x \/ Zle (next x) a.
    intros.
    split; intros.
    apply Z.le_lteq in H.
    elim H; intros.
    right.
    unfold next.
    omega.
    left ; auto.

    rewrite Z.le_lteq.
    elim H; intros.
    right; auto.
    left; unfold next in H0; omega.
  Qed.
End Z_has_next.

Module Z_has_dist <: has_dist Z_has_le Z_has_next.
  Import Z_has_le.
  Import Z_has_next.
  Definition dist := fun a b:Z => Z.to_nat (b-a).
    Lemma dist_a': forall n a, _iter next a n = (a+ Z.of_nat n)%Z.
       intro.
       induction n.
       intros.
       simpl.
       omega.

       intros.
       rewrite Nat2Z.inj_succ.
       simpl.
       rewrite IHn.
       unfold next.
       omega.
    Qed.

  Lemma dist_a : forall a b, le a b -> _iter next a (dist a b)  =b.
    intros a b.
    intro.
    assert (b = a + Z.of_nat (dist a b))%Z.
    unfold dist.
    rewrite Z2Nat.id.
    omega.
    unfold le in H; omega.
    rewrite H0 at 2.
    apply dist_a'.
  Qed.
End Z_has_dist.

(* nat has le next and dist *)

Module nat_has_le <: has_le.
  Definition A := nat.
  Definition le := le.

  Definition le_refl:=le_refl.
  Definition le_antisymm :=le_antisym.
  Definition le_trans := le_trans.
End nat_has_le.

Module nat_has_next <: has_next nat_has_le.
  Definition next := fun x => (S x).
  Lemma next_is_smallest: forall (x a:nat), le x a <-> a = x \/ le (next x) a.
    intros.
    split; intros.
    apply le_lt_or_eq_iff in H.
    elim H; intros.
    right.
    unfold next.
    omega.
    left ; auto.
    rewrite le_lt_or_eq_iff.
    elim H; intros.
    right; auto.
    left; unfold next in H0; omega.
  Qed.
End nat_has_next.

Module nat_has_dist <: has_dist nat_has_le nat_has_next.
  Import nat_has_le.
  Import nat_has_next.
  Definition dist := fun a b: nat => (b-a)%nat.
    Lemma dist_a': forall n a, _iter next a n = (a+n)%nat.
       intro.
       induction n.
       intros.
       simpl.
       omega.

       intros.
       simpl.
       rewrite IHn.
       unfold next.
       omega.
    Qed.

  Lemma dist_a : forall a b, le a b -> _iter next a (dist a b)  =b.
    intros a b.
    intro.
    assert (b = a + (dist a b))%nat.
    unfold dist.
    unfold le in H.
    omega.
    rewrite H0 at 2.
    apply dist_a'.
  Qed.
End nat_has_dist.

Module Z_range := Range Z_has_le Z_has_next Z_has_dist.

Module nat_range := Range nat_has_le nat_has_next nat_has_dist.

Ltac nat_range_unfold_all H:=try unfold nat_range.gen_prop in H;try unfold nat_has_next.next in H;try unfold nat_has_dist.dist in H;try unfold nat_has_le.A in H.

Ltac Z_range_unfold_all H:=try unfold Z_range.gen_prop in H;try unfold Z_has_next.next in H;try unfold Z_has_dist.dist in H;try unfold Z_has_le.A in H.

Ltac stdrange_fin_elem :=
  repeat progress
  match goal with
      | H : ( _ <= ?a (?b _) <= _)%nat |- _ => apply nat_range.range_l_r_fin_elem in H;[cbv beta delta -[a b] iota in H| unfold nat_has_le.le; omega]
      | H : ( _ <= ?a _ _ <= _)%nat |- _ => apply nat_range.range_l_r_fin_elem in H;[cbv beta delta -[a] iota in H| unfold nat_has_le.le; omega]
      | H : ( _ <= ?a _ <= _)%nat |- _ => apply nat_range.range_l_r_fin_elem in H;[cbv beta delta -[a] iota in H| unfold nat_has_le.le; omega]
      | H : ( _ <= _ <= _)%nat |- _ => apply nat_range.range_l_r_fin_elem in H;[cbv beta delta iota in H| unfold nat_has_le.le; omega]
      | H : ( _ <= ?a (?b _) <= _)%Z |- _ => apply Z_range.range_l_r_fin_elem in H;[cbv beta delta -[a b] iota in H| unfold Z_has_le.le; omega]
      | H : ( _ <= ?a _ _ <= _)%Z |- _ => apply Z_range.range_l_r_fin_elem in H;[cbv beta delta -[a] iota in H| unfold Z_has_le.le; omega]
      | H : ( _ <= ?a _ <= _)%Z |- _ => apply Z_range.range_l_r_fin_elem in H;[cbv beta delta -[a] iota in H| unfold Z_has_le.le; omega]
      | H : ( _ <= _ <= _ )%Z   |- _ => apply Z_range.range_l_r_fin_elem  in H;[cbv beta delta iota in H| unfold Z_has_le.le; omega]
      | _ => fail
  end.

(* range split part end *)

Open Scope nat_scope.
  Lemma nat_lt2stdrange : forall x b:nat, x<b -> 0<=x<=(pred b).
    intros;set (le_0_n x); split; auto.
    omega.
  Qed.

  Lemma nat_le2stdrange : forall x b:nat,  x<=b -> 0<=x<=b.
    intros; set (le_0_n x);split; auto.
  Qed.

  Lemma nat_gt2stdrange : forall x b:nat, b>x -> 0<=x<=(pred b).
    intros; set (le_0_n x); split; auto.
    omega.
  Qed.
  Lemma nat_ge2stdrange: forall x b, b>=x -> 0<=x<=b.
    intros; set (le_0_n x); split; auto.
  Qed.
Close Scope nat_scope.

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

Open Scope Z_scope.
  Lemma unsigned_lt2stdrange : forall x b, Int.unsigned x< b -> 0<=Int.unsigned x <= (Z.pred b).
    intros;split;[set (Int.unsigned_range x); tauto| omega].
  Qed.

  Lemma unsigned_le2stdrange : forall x b, Int.unsigned x<=b -> 0<=Int.unsigned x<=b.
    intros;split;[set (Int.unsigned_range x); tauto| omega].
  Qed.

  Lemma unsigned_gt2stdrange : forall x b,  b > Int.unsigned x -> 0<=Int.unsigned x <= (Z.pred b).
    intros;split;[set (Int.unsigned_range x); tauto| omega].
  Qed.

  Lemma unsigned_ge2stdrange : forall x b, b >= Int.unsigned x -> 0<=Int.unsigned x<=b.
    intros;split;[set (Int.unsigned_range x); tauto| omega].
  Qed.

  Lemma repr_unsigned : forall x n, Int.unsigned x = n -> x= Int.repr n.
    intros.
    rewrite <- H.
    rewrite Int.repr_unsigned.
    reflexivity.
  Qed.

  (* TODO: change this function *)
  Ltac pre' :=
    match goal with
       | H : (?x <  ?b)%nat |- _                => apply nat_lt2stdrange in H
       | H : (?x <= ?b)%nat |- _                => apply nat_le2stdrange in H
       | H : (?b >  ?x)%nat |- _                => apply nat_gt2stdrange in H
       | H : (?b >= ?x)%nat |- _                => apply nat_ge2stdrange in H
       | H : (Int.unsigned ?x <  ?b)     |- _   => apply unsigned_lt2stdrange in H
       | H : (Int.unsigned ?x <= ?b)     |- _   => apply unsigned_le2stdrange in H
       | H : (?b >  Int.unsigned ?x )    |- _   => apply unsigned_gt2stdrange in H
       | H : (?b >= Int.unsigned ?x)     |- _   => apply unsigned_ge2stdrange in H
       | H : (?a < ?x < ?b)%nat |- _            => let H' := fresh in rename H into H'; assert ( (S a) <= x <= (pred b))%nat as H by omega; clear H'
       | H : (?a <= ?x < ?b)%nat |- _           => let H' := fresh in rename H into H'; assert ( (a) <= x <= (pred b))%nat as H by omega; clear H'
       | H : (?a < ?x <= ?b)%nat |- _           => let H' := fresh in rename H into H'; assert ( (S a) <= x <= ( b))%nat as H by omega; clear H'
       | H : (?a < ?x < ?b) |- _                => let H' := fresh in rename H into H'; assert ( (1+ a) <= x <= (Z.pred b)) as H by omega; clear H'
       | H : (?a <= ?x < ?b) |- _               => let H' := fresh in rename H into H'; assert ( (a) <= x <= (Z.pred b)) as H by omega; clear H'
       | H : (?a < ?x <= ?b) |- _               => let H' := fresh in rename H into H'; assert ( (1+ a) <= x <= ( b)) as H by omega; clear H'
    end.

  Ltac pre := repeat pre';repeat ((* handle even not a real range, 1<=x<=0 for example*)try omega; timeout 8 stdrange_fin_elem).
  Ltac pre_noto := repeat pre';repeat ((* handle even not a real range, 1<=x<=0 for example*)try omega; stdrange_fin_elem).

  (* do NOT use this *)
  (* use a tactic as a param in another tactic is VERY slow*)
  Ltac brute_force tac:=
    match goal with
        | H : _ \/ _ |- _ => destruct H; brute_force tac
        | _               => tac
    end.

  Lemma sample'' : forall n , (0< n<63)%nat ->True.
    intros.
    pre.
    auto.
  Qed.

  Lemma sample0: forall n m :int32,  Int.unsigned m < 64 -> 64 > Int.unsigned n ->  True.
    intros.
    pre.
    auto.
  Qed.

  Lemma sample1: forall n:nat, (n<25)%nat-> True.
    intros.
    pre.
    auto.
  Qed.

  Lemma sample2: forall n:nat, (25>n)%nat-> True.
    intros.
    pre.
    auto.
  Qed.

  Ltac math_solver_pre :=
    match goal with
        | H : Int.unsigned _ = _ |- _ => apply repr_unsigned in H
        | _  => idtac
    end.

  (* can use compute -[Int.unsigned Int.mone] instead *)
  Ltac munfold :=try unfold Int.shru; try unfold Int.shl; try unfold Int.not; try unfold Z.shiftr; try unfold Int.xor; try unfold Int.and; try unfold Z.to_nat; try unfold Pos.to_nat; try unfold Int.or; try unfold Z.lor; try unfold Int.divu; try unfold Int.add; try unfold Int.mul; try unfold Int.sub; try unfold Int.ltu; try unfold Int.zero; try unfold Int.one; try unfold Int.eq.

  Ltac mycompute := compute -[Int.unsigned].

(*
Lemma div_in_intrange: forall x a mx:Z, (0<=x <=mx -> a>0 -> 0<= Z.div x a <=mx)%Z.
  intros.
  split.
  ht.revs.
  apply Z_div_ge0.
  omega.
  omega.
  apply Z.div_le_upper_bound.
  omega.
  elim H; intros.
  eapply Zle_trans.
  exact H2.
  ht.revs.
  apply a_mult_b_ge_b; omega.
Qed.
  Ltac solve_int_range :=
match goal with
    | i : int32 |- _ => let xval := fresh in let xrange := fresh in destruct i as [xval xrange]; unfold Int.modulus, two_power_nat, shift_nat in xrange; simpl in xrange; simpl in *;  solve_int_range
    | _ => subst; try rewrite max_unsigned_val; solve [ omega | apply div_in_intrange; omega ]
end.
  Ltac rangesolver :=try solve_int_range; repeat (rewrite Int.unsigned_repr; try solve_int_range).
  Ltac ur_rewriter := rewrite Int.unsigned_repr; [idtac| rangesolver].
  Ltac ur_rewriter_in H := rewrite Int.unsigned_repr in H; [idtac| rangesolver].
 *)
  Ltac trivial_ur_rewriter := rewrite Int.unsigned_repr;[idtac| rewrite max_unsigned_val; omega].

  Ltac subst_all := subst.

(* not so basic *)
  Ltac basic_solver := match goal with
| H : Int.unsigned ?a = ?b |- _  => rewrite H in *; apply repr_unsigned in H; basic_solver
| _  => subst_all; simpl; repeat trivial_ur_rewriter; simpl; solve [auto| omega |  timeout 2 mycompute; intros; try split; tryfalse; try omega; auto]
end.
  Ltac basic_solver_noto := match goal with
| H : Int.unsigned ?a = ?b |- _  => rewrite H in *; apply repr_unsigned in H; basic_solver
| _  => subst_all; simpl; repeat trivial_ur_rewriter; simpl; solve [auto| omega |  mycompute; intros; try split; tryfalse; try omega; auto]
end.

  Ltac bf_basic_solver :=
    repeat progress
           match goal with
             | H : _ \/ _ |- _  => destruct H;
                                  [match goal with
                                     |  H' : _\/_ |- _ => destruct H';
                                                         [match goal with
                                                            |  H'' : _\/_ |- _ => destruct H''; [basic_solver | idtac]
                                                            |  _ => basic_solver
                                                          end | idtac ]
                                     |  _ => basic_solver
                                   end | idtac ]
             | _ => basic_solver
           end.

  Ltac bf_basic_solver_noto :=
    repeat progress
           match goal with
             | H : _ \/ _ |- _  => destruct H;
                                  [match goal with
                                     |  H' : _\/_ |- _ => destruct H';
                                                         [match goal with
                                                            |  H'' : _\/_ |- _ => destruct H''; [basic_solver_noto | idtac]
                                                            |  _ => basic_solver_noto
                                                          end | idtac ]
                                     |  _ => basic_solver_noto
                                   end | idtac ]
             | _ => basic_solver_noto
           end.

  Ltac basic_solver_safe := match goal with
| H : Int.unsigned ?a = ?b |- _  => rewrite H; apply repr_unsigned in H; basic_solver_safe
| _  => subst_all; simpl;  split; try omega
end.

Ltac bf1_basic_solver :=
   match goal with
     | H : _ \/ _ |- _  => solve[clear -H; repeat (destruct H as [H | H] ;[basic_solver_safe| idtac] ) ; basic_solver_safe]
   end.

Ltac clear_useless_or :=
  match goal with
      | H : _ ?a = _ \/ _ |- _ => clear dependent a
      | H : ?a = _ \/ _   |- _ => clear dependent a
end.

Ltac clear_all_useless_or := repeat clear_useless_or.

Ltac mrewrite := repeat rewrite unsigned_mone_val; repeat rewrite Int.unsigned_repr; try rewrite max_unsigned_val; [idtac|solve [clear; omega |  clear_all_useless_or;  bf_basic_solver] .. ].
Ltac mrewrite_noto := repeat rewrite unsigned_mone_val; repeat rewrite Int.unsigned_repr; try rewrite max_unsigned_val; [idtac|solve [clear; omega |  clear_all_useless_or;  bf_basic_solver_noto] .. ].

  Ltac new_mathsolver:= munfold; pre; mrewrite; bf_basic_solver.
  Ltac new_mathsolver_noto := munfold; pre_noto; mrewrite_noto; bf_basic_solver_noto.
  (* old version *)
  Ltac math_rewrite :=
    repeat progress (
             try rewrite Int.unsigned_repr in *;
             try rewrite max_unsigned_val in *;
             try omega ;
             try rewrite unsigned_mone_val in *;
             try omega; auto).

  Ltac math_solver:=
    math_solver_pre;
    subst;
    try simpl in *;
    try unfold Int.shru in *;
    try unfold Int.shl in *;
    try unfold Int.not in *;
    try unfold Z.shiftr in *;
    try unfold Int.xor in *;
    try unfold Int.and in *;
    try unfold Z.to_nat in *;
    try unfold Pos.to_nat in *;
    try unfold Int.or in *;
    try unfold Z.lor in *;
    try unfold Int.divu in *;
    try unfold Int.add in *;
    try unfold Int.mul in *;
    try unfold Int.sub in *;
    try unfold Int.ltu in *;
    try unfold Int.zero in *;
    try unfold Int.one in *;
    try unfold Int.eq in *;
    match goal with
      | H : ?f  _  =  _ |- _ => simpl f in H;  inverts H
      | _ => idtac
    end;
    math_rewrite;
    try simpl in *;
    math_rewrite;
    intuition tryfalse;
    try (simpl; omega).

  Ltac mathsolver' :=
    repeat progress
           match goal with
             | H : False |- _ => inversion H
             | H : _ \/ _ |- _  => destruct H;
                                  [match goal with
                                     |  H' : _\/_ |- _ => destruct H';
                                                         [match goal with
                                                            |  H'' : _\/_ |- _ => destruct H''; [math_solver | idtac]
                                                            |  _ => math_solver
                                                          end | idtac ]
                                     |  _ => math_solver
                                   end | idtac ]
             | _ => math_solver
           end.

  Ltac mathsolver:= pre; mathsolver'.

End _mathsolver.
(*
Require Import memory. (* for Vint32 *)
Require Import OSTCBInvDef. (* for OSUnMapVallist *)
Require Import BaseAsrtDef. (* for nth_val' *)

Module _mathsolver_ext.
  Close Scope nat_scope.
  Open Scope Z_scope.
  Definition deref_Vint32_unsafe (x:val): int32 :=
    match x with
        | Vint32 x => x
        | _ => (Int.repr 0)
    end.

  Lemma OSUnMapVallist_safe_deVint32 : forall z y, 0<=z<=255 -> nth_val' (Z.to_nat z) OSUnMapVallist = Vint32 y -> y = deref_Vint32_unsafe ( nth_val' (Z.to_nat z) OSUnMapVallist).
Proof.
  intros.
  _mathsolver.pre.
  repeat (destruct H; [rewrite H in *; simpl in H0; inversion H0; auto| idtac]).
  rewrite H in *; simpl in H0; inversion H0; auto.
Qed.

  Lemma OSMapVallist_safe_deVint32 : forall z y, 0<=z<=7 -> nth_val' (Z.to_nat z) OSMapVallist = Vint32 y -> y = deref_Vint32_unsafe ( nth_val' (Z.to_nat z) OSMapVallist).
    intros.
    _mathsolver.pre.
    repeat (destruct H; [rewrite H in *; simpl in H0; inversion H0; auto| idtac]).
    rewrite H in *; simpl in H0; inversion H0; auto.
  Qed.

  Ltac deref_vint32_for_array := match goal with
                                 | H : nth_val' (Z.to_nat (Int.unsigned ?a) ) OSUnMapVallist = Vint32 _ |- _=> apply OSUnMapVallist_safe_deVint32 in H;[unfold deref_Vint32_unsafe in H; try rewrite H in *; clear H |set (@Int.unsigned_range_2 a); try omega]
                                 | H : nth_val' (Z.to_nat (Int.unsigned ?a) ) OSMapVallist = Vint32 _ |- _ => apply OSMapVallist_safe_deVint32 in H; [unfold deref_Vint32_unsafe in H; try rewrite H in *; clear H | set (@Int.unsigned_range_2 a);  try omega]
                                 | H : nth_val' (Z.to_nat _ ) OSUnMapVallist = Vint32 _ |- _=> apply OSUnMapVallist_safe_deVint32 in H;[unfold deref_Vint32_unsafe in H; try rewrite H in *; clear H | try omega]
                                 | H : nth_val' (Z.to_nat _ ) OSMapVallist = Vint32 _ |- _ => apply OSMapVallist_safe_deVint32 in H; [unfold deref_Vint32_unsafe in H; try rewrite H in *; clear H | try omega]
                                 end.
End _mathsolver_ext.
*)

Ltac mauto := (*repeat _mathsolver_ext.deref_vint32_for_array; *)_mathsolver.new_mathsolver.
Ltac mauto_noto := (*repeat _mathsolver_ext.deref_vint32_for_array;*) _mathsolver.new_mathsolver_noto.
Ltac mauto_old := _mathsolver.mathsolver.
Ltac mauto_dbg := _mathsolver.pre.
*)


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

(* * Minsky machines to FRACTRAN programs *)
(* ** Removal of self-loops in MMs *)

Require Import List Arith Lia.

From Undecidability.Shared.Libs.DLW
  Require Import utils pos vec subcode sss.

From Undecidability.MinskyMachines.MM
  Require Import mm_defs.

Set Implicit Arguments.

Tactic Notation "rew" "length" := autorewrite with length_db.

Local Notation "e #> x" := (vec_pos e x).
Local Notation "e [ v / x ]" := (vec_change e x v).

Local Notation "I // s -1> t" := (mm_sss I s t).
Local Notation "P // s -[ k ]-> t" := (sss_steps (@mm_sss _) P k s t).
Local Notation "P // s -+> t" := (sss_progress (@mm_sss _) P s t).
Local Notation "P // s ->> t" := (sss_compute (@mm_sss _) P s t).
Local Notation "P // s '~~>' t" := (sss_output (@mm_sss _) P s t).
Local Notation "P // s ↓" := (sss_terminates (@mm_sss _) P s).

Section self_loops.

  Variables (n : nat) (P : list (mm_instr (pos n))).

  Lemma mm_self_loop_no_term_1 i x s v :
              (i,DEC x i::nil) <sc (1,P)
           -> s = (i,v)
           -> v#>x = 0
           -> ~ (1,P) // s ↓.
  Proof.
    intros H1 H2 H3 (s0 & H4).
    revert i x v H1 H2 H3.
    pattern s; revert H4; apply mm_term_ind.
    + intros Hs0 i x v H1 H2 H3.
      subst s0.
      revert Hs0; apply in_out_code.
      apply subcode_in_code with (1 := H1).
      simpl; lia.
    + intros i ρ v j w H1 H2 H3 IH3 k x p G1 G2 G3.
      inversion G2; subst p k.
      generalize (subcode_cons_inj _ _ _ _ H1 G1); intros; subst.
      apply mm_sss_DEC0_inv in H2; auto.
      destruct H2; subst j w.
      apply (IH3 _ _ _ G1 eq_refl); auto.
  Qed.

  Lemma mm_self_loop_no_term_2 i x s v :
              (i,DEC x (1+i)::DEC x i::nil) <sc (1,P)
           -> s = (i,v) \/ s = (1+i,v)
           -> v#>x = 0
           -> ~ (1,P) // s ↓.
  Proof.
    intros H1 H2 H3 (s0 & H4).
    revert v H2 H3.
    pattern s; revert H4; apply mm_term_ind.
    + intros Hs0 v H2 H3.
      destruct H2; subst s0; revert Hs0; apply in_out_code;
        apply subcode_in_code with (1 := H1); simpl; lia.
    + apply subcode_cons_invert_left in H1.
      destruct H1 as [ G0 G1 ].
      intros l ρ v j w H1 H2 H3 IH3 r G2 G3.
      destruct G2 as [ G2 | G2 ]; inversion G2; subst l v.
      * generalize (subcode_cons_inj _ _ _ _ H1 G0); intros; subst.
        apply mm_sss_DEC0_inv in H2; auto.
        destruct H2; subst j w.
        revert G3; apply IH3; auto.
      * generalize (subcode_cons_inj _ _ _ _ H1 G1); intros; subst.
        apply mm_sss_DEC0_inv in H2; auto.
        destruct H2; subst j w.
        revert G3; apply IH3; auto.
  Qed.

End self_loops.

Section no_self_loops.

  Variables (n : nat).

  Definition mm_no_self_loops (Q : nat * list (mm_instr (pos n))) := forall i x, ~ (i,DEC x i::nil) <sc Q.

  Implicit Types (P Q : list (mm_instr (pos n))).

  Fact mm_no_self_loops_app i P Q : mm_no_self_loops (i,P)
                                 -> mm_no_self_loops (length P +i,Q)
                                 -> mm_no_self_loops (i,P++Q).
  Proof.
    intros H1 H2 j x H.
    apply subcode_app_invert_right in H.
    destruct H as [ H | H ]; revert H.
    + apply H1.
    + apply H2.
  Qed.

End no_self_loops.

Section remove_self_loops.

  (* To safely remove self loops from (1,P)
        1/ we map them to 2+lP
        2/ we map outside jumps to 0
        3/ we append to P to 3 following instructions
             1+lP: DEC nv 0; DEC nv 3+lP; DEC nv 2+lP

           where nv is a new and unused variable
    *)

  Variables (n : nat).

  Implicit Types (P Q : list (mm_instr (pos n))).

  Let f k i (ρ : mm_instr (pos n)) :=
    match ρ with
      | INC x   => INC (pos_nxt x)
      | DEC x j => DEC (pos_nxt x) (if eq_nat_dec i j     then 1+k
                                    else if le_lt_dec k j then 0
                                                          else j)
    end.

  Let Fixpoint g k i P :=
    match P with
      | nil  => nil
      | ρ::P => f k i ρ :: g k (S i) P
    end.

  Let g_app k i P Q : g k i (P++Q) = g k i P ++ g k (length P + i) Q.
  Proof.
    revert i; induction P as [ | ? P IHP ]; intros i; simpl; f_equal; auto.
    rewrite IHP; do 2 f_equal; lia.
  Qed.

  Let g_app_inv k i P l r : g k i P = l ++ r -> exists L R, P = L++R /\ l = g k i L /\ r = g k (length l+i) R.
  Proof.
    revert i l r.
    induction P as [ | ρ P IHP ]; intros i l r; simpl.
    + intros H; symmetry in H; exists nil, nil; simpl.
      apply app_eq_nil in H; tauto.
    + destruct l as [ | y l ]; simpl.
      * exists nil, (ρ::P); simpl in *; auto.
      * intros H; injection H; clear H; intros H1 H2.
        destruct IHP with (1 := H1) as (L & R & G1 & G2 & G3); subst.
        exists (ρ::L), R; simpl; repeat (split; auto).
        f_equal; lia.
  Qed.

  Let length_g l i P : length (g l i P) = length P.
  Proof. revert i; induction P; simpl; auto. Qed.

  Let g_subcode k i P j ρ : (j,ρ::nil) <sc (i,P) -> (j, f k j ρ::nil) <sc (i,g k i P).
  Proof.
    intros (l & r & H1 & H2); subst P.
    rewrite g_app; simpl.
    exists (g k i l), (g k (S (length l+i)) r); split.
    + do 3 f_equal; lia.
    + rewrite length_g; auto.
  Qed.

  Let subcode_g k i P j ρ : (j,ρ::nil) <sc (i,g k i P) -> exists ρ', (j,ρ'::nil) <sc (i,P) /\ ρ = f k j ρ'.
  Proof.
    intros (l & r & H1 & H2).
    apply g_app_inv in H1.
    destruct H1 as (L & [ | ρ' R ] & H1 & H3 & H4); try discriminate.
    simpl in H4; inversion H4.
    exists ρ'; split; auto.
    + exists L, R; simpl; split; auto.
      rewrite H3, length_g in H2; auto.
    + f_equal; lia.
  Qed.

  Let g_loops k i P : 1 <= i -> i+length P <= k -> mm_no_self_loops (i,g k i P).
  Proof.
    intros H0 H1 j x H2.
    apply subcode_g in H2.
    destruct H2 as ([ y | y q ] & H2 & H3); simpl in H3; try discriminate.
    inversion H3; subst; simpl in H1.
    apply subcode_in_code with (i:= j) in H2; simpl in H2 |- *; try lia.
    destruct (eq_nat_dec j q); try lia.
    destruct (le_lt_dec k q); lia.
  Qed.

  Variable P : list (mm_instr (pos n)).

  Notation lP := (length P).

  Let R : list (mm_instr (pos (S n))) :=
                                   DEC pos0 0
                                :: DEC pos0 (3+lP)
                                :: DEC pos0 (2+lP)
                                :: nil.

  Let sc_R_1 : (1+lP, DEC pos0 0 :: nil) <sc (1+lP, R).
  Proof. unfold R; auto. Qed.

  Let sc_R_2 : (2+lP, DEC pos0 (1+(2+lP)) :: DEC pos0 (2+lP) :: nil) <sc (1+lP, R).
  Proof.
    unfold R; rewrite Nat.add_assoc; simpl plus.
    exists (DEC pos0 0 :: nil), nil; simpl; split; auto; lia.
  Qed.

  Let R_sc i rho : (i,rho::nil) <sc (1+lP,R) -> i = 1+lP /\ rho = DEC pos0 0
                                             \/ i = 2+lP /\ rho = DEC pos0 (3+lP)
                                             \/ i = 3+lP /\ rho = DEC pos0 (2+lP).
  Proof.
    unfold R; intros ([ | u [ | v [ | w l ] ] ] & r & H1 & H2); inversion H1; subst i; simpl.
    + do 0 right; left; split; auto; lia.
    + do 1 right; left; split; auto; lia.
    + do 2 right; split; auto; lia.
    + destruct l; discriminate.
  Qed.

  Let R_no_self_loops : mm_no_self_loops (1+lP,R).
  Proof.
    intros i rho H.
    apply R_sc in H.
    destruct H as [ (H1 & H2) | H ].
    { inversion H2; lia. }
    destruct H as [ (H1 & H2) | H ].
    { inversion H2; lia. }
    destruct H as (H1 & H2).
    { inversion H2; lia. }
  Qed.

  Let Q := g (1+lP) 1 P ++ R.

  Let Q_no_self_loops : mm_no_self_loops (1,Q).
  Proof.
    apply mm_no_self_loops_app.
    + apply g_loops; simpl; lia.
    + rewrite length_g, Nat.add_comm; auto.
  Qed.

  Let sc_Q_1 j ρ : (j,ρ::nil) <sc (1,P) -> (j, f (1+lP) j ρ::nil) <sc (1,Q).
  Proof. intro; apply subcode_app_end, g_subcode; auto. Qed.

  Let sc_Q_2 : (1+lP, DEC pos0 0 :: DEC pos0 (3+lP) :: DEC pos0 (2+lP) :: nil) <sc (1,Q).
  Proof. apply subcode_right; rewrite length_g; auto. Qed.

  Let sc_Q_3 : (2+lP, DEC pos0 (3+lP) :: DEC pos0 (2+lP) :: nil) <sc (1,Q).
  Proof. apply subcode_trans with (2 := sc_Q_2); auto. Qed.

  Let Q_sc j ρ : (j,ρ::nil) <sc (1,Q)
              -> (exists ρ', (j,ρ'::nil) <sc (1,P) /\ ρ = f (1+lP) j ρ')
              \/ j = 1+lP /\ ρ = DEC pos0 0
              \/ j = 2+lP /\ ρ = DEC pos0 (3+lP)
              \/ j = 3+lP /\ ρ = DEC pos0 (2+lP).
  Proof.
    intros H.
    apply subcode_app_invert_right in H.
    destruct H as [ H | H ].
    + apply subcode_g in H; auto.
    + rewrite length_g, Nat.add_comm in H.
      apply R_sc in H; auto.
  Qed.

  Let Q_length : length Q = length P + 3.
  Proof.
    unfold Q; rewrite app_length, length_g.
    unfold R; auto.
  Qed.

  Let Q_bound i x j : (i,DEC x j::nil) <sc (1,Q) -> j < 1+length Q.
  Proof.
    rewrite Q_length; intros H.
    apply Q_sc in H.
    destruct H as [ (rho & H1 & H2) | H ].
    { destruct rho as [ | y p ]; try discriminate.
      unfold f in H2.
      destruct (eq_nat_dec i p).
      { inversion H2; lia. }
      destruct (le_lt_dec (1+lP) p); inversion H2; lia. }
    destruct H as [ (H1 & H2) | H ].
    { inversion H2; lia. }
    destruct H as [ (H1 & H2) | H ].
    { inversion H2; lia. }
    destruct H as (H1 & H2).
    { inversion H2; lia. }
  Qed.

  Let P_imp_Q_strong s s0 : in_code (fst s) (1,P) -> (1,P) // s ~~> s0 -> (1,Q) // (fst s, 0##snd s) ~~> (0, 0 ## snd s0).
  Proof.
    intros H1 H; revert H1.
    pattern s; revert s H; apply mm_term_ind.
    + simpl; intros; lia.
    + intros i [ x | x p ] v j w H1 H2 H3 H5 H4; unfold fst, snd in *.
      * apply mm_sss_INC_inv in H2.
        destruct H2 as (G1 & G2).
        destruct (eq_nat_dec i lP) as [ Hi | Hi ].
        - assert (Eq : snd s0 = w). {
            destruct H3 as [[k H3] _]; eauto.
            eapply sss_steps_stall in H3 as [_ <-]. reflexivity.
            cbn. lia.
          }
          unfold snd in Eq. rewrite Eq.
          split; try (simpl; lia).
          apply sc_Q_1 in H1; simpl f in H1.
          mm sss INC with (pos_nxt x).
          subst i; clear H1; mm sss DEC zero with pos0 0.
          mm sss stop; f_equal; simpl; subst; auto.
        - spec in H5. { subst j; simpl in H4 |- *; lia. }
          apply sc_Q_1 in H1; simpl f in H1.
          split. 2:eapply H5.
          eapply subcode_sss_compute_instr with (2 := H1).
          2: eapply H5.
          subst. constructor.
      * generalize H1; intros H6.
        apply sc_Q_1 in H6; unfold f in H6.
        case_eq (v#>x).
        ++ intros Hx.
           destruct (eq_nat_dec i p) as [ Hip | Hip ].
           -- subst p.
              destruct mm_self_loop_no_term_1 with (s := (i,v)) (v := v) (1 := H1); auto.
              exists s0.
              destruct H3 as [ H3 H7 ]; split; auto.
              apply subcode_sss_compute_instr with (1 := H2) (3 := H3); auto.
           -- destruct (le_lt_dec (1+lP) p) as [ Hp1 | Hp1 ];
                [ | destruct (eq_nat_dec p 0) as [ Hp2 | Hp2 ] ].
              ** split; try (simpl; lia).
                 mm sss DEC zero with (pos_nxt x) 0.
                 mm sss stop. repeat f_equal.
                 inversion H2; subst; clear H2.
                 --- destruct H3 as [[k H3] _]; eauto.
                     eapply sss_steps_stall in H3 as [_ <-]. reflexivity.
                     cbn. lia.
                 --- lia.
              ** subst p.
                 split; try (simpl; lia).
                 mm sss DEC zero with (pos_nxt x) 0.
                 mm sss stop. repeat f_equal.
                 inversion H2; subst; clear H2.
                 --- destruct H3 as [[k H3] _]; eauto.
                     eapply sss_steps_stall in H3 as [_ <-]. reflexivity.
                     cbn. lia.
                 --- lia.
              ** apply mm_sss_DEC0_inv with (1 := Hx) in H2.
                 destruct H2; subst j w.
                 spec in H5. { simpl; lia. }
                 split. 2:eapply H5.
                 eapply subcode_sss_compute_instr with (2 := H6).
                 2: eapply H5.
                 constructor; simpl; eauto.
        ++ intros u Hx.
           apply mm_sss_DEC1_inv with (1 := Hx) in H2.
           destruct H2 as [ ? H2 ]; subst j.
           destruct (eq_nat_dec i lP) as [ Hi | Hi ].
           -- assert (Eq : snd s0 = w). {
                destruct H3 as [[k H3] _]; eauto.
                eapply sss_steps_stall in H3 as [_ <-]. reflexivity.
                cbn. lia.
              }
              unfold snd in Eq. rewrite Eq.
              split; simpl; auto.
              apply subcode_sss_compute_instr with (2 := H6) (st2 := (1+i,0##w)); auto.
              ** replace (0##w) with ((0##v)[u/pos_nxt x]); subst; auto; constructor; auto.
              ** subst i; mm sss DEC zero with pos0 0; mm sss stop.
           -- spec in H5. { simpl in H4 |- *; lia. }
              split. 2: eapply H5.
              eapply subcode_sss_compute_instr with (2 := H6); auto.
              2: eapply H5.
              replace (0##w) with ((0##v)[u/pos_nxt x]); subst; auto; constructor; auto.
  Qed.

  Let P_imp_Q s s0 : in_code (fst s) (1,P) -> (1,P) // s ~~> s0 -> (1,Q) // (fst s, 0##snd s) ↓.
  Proof.
    intros H1 H. eapply P_imp_Q_strong in H; eauto.
    eexists. eauto.
  Qed.

  Let Q_imp_P s s0 : in_code (fst s) (1,P) -> (snd s)#>pos0 = 0 -> (1,Q) // s ~~> s0 -> (1,P) // (fst s, vec_tail (snd s)) ↓.
  Proof.
    intros H1 H2 H3; revert H1 H2.
    pattern s; revert s H3; apply mm_term_ind.
    + simpl; intros; lia.
    + intros i ρ v j w H1 H2 H3 H4 H5 H6; unfold fst, snd in *.
      rewrite (vec_head_tail v) in H2, H6.
      revert H2 H6.
      generalize (vec_head v) (vec_tail v); clear v; intros x v; simpl; intros H2 H6; subst x.
      destruct Q_sc with (1 := H1) as [ ([ x | x p ] & G1 & G2) | G1 ]; try subst ρ.
      * unfold f in H2.
        apply mm_sss_INC_inv in H2.
        destruct H2 as (? & H2); subst j w.
        revert H4; rew vec; simpl; intros H4.
        destruct (eq_nat_dec i lP) as [ Hi | Hi ].
        - exists (S i, v[(S (v#>x))/x]); split; try (simpl; lia).
          mm sss INC with x; mm sss stop.
        - spec in H4. simpl in H5; lia. spec in H4; auto.
          apply subcode_sss_terminates_instr with (2 := G1) (3 := H4); auto; constructor.
      * unfold f in H2; case_eq (v#>x).
        - intros Hx.
          apply mm_sss_DEC0_inv in H2; auto.
          destruct H2; subst j w.
          destruct (eq_nat_dec i p) as [ Hip | Hip ].
          ** subst p; exfalso.
             generalize (ex_intro _ s0 H3); simpl.
             change (~ (1,Q) // (2+lP,0##v) ↓).
             apply mm_self_loop_no_term_2 with (v := 0##v) (1 := sc_Q_3); auto.
          ** destruct (le_lt_dec (1+lP) p) as [ Hp | Hp ];
               [ | destruct (eq_nat_dec p 0) as [ Hp2 | Hp2 ] ].
             ++ exists (p,v); split; try (simpl; lia).
                mm sss DEC zero with x p; mm sss stop.
             ++ exists (p,v); split; try (simpl; lia).
                mm sss DEC zero with x p; mm sss stop.
             ++ spec in H4. simpl in H5 |- *; lia.
                spec in H4; auto.
                apply subcode_sss_terminates_instr with (2 := G1) (3 := H4); auto; constructor.
                simpl; auto.
        - intros u Hx.
          apply mm_sss_DEC1_inv with (u := u) in H2; auto.
          destruct H2; subst j w.
          simpl in H4.
          destruct (eq_nat_dec i lP) as [ Hi | Hi ].
          ** exists (S i, v[u/x]); split; try (simpl; lia).
             mm sss DEC S with x p u; mm sss stop.
          ** spec in H4. simpl in H5; lia.
             spec in H4; auto.
             apply subcode_sss_terminates_instr with (2 := G1) (3 := H4); auto.
             constructor; auto.
      * destruct G1 as [ (? & _) | [ (? & _) | (? & _) ] ]; simpl in H5; lia.
  Qed.

  Theorem mm_remove_self_loops : { Q |  mm_no_self_loops (1,Q)
                                     /\ (forall i x j, (i,DEC x j::nil) <sc (1,Q) -> j < 1+length Q)
                                     /\ forall v, (1,P) // (1,v) ↓ <-> (1,Q) // (1,0##v) ↓ }.
  Proof.
    destruct (eq_nat_dec lP 0) as [ HlP | HlP ].
    +  exists nil.
       split; [ | split ].
       - intros i rho ([ | ] & ? & ? & ?); discriminate.
       - intros i x j ([ | ] & ? & ? & ?); discriminate.
       - destruct P; try discriminate.
         split.
         * exists (1,0##v); split; simpl; try lia; mm sss stop.
         * exists (1,v); split; simpl; try lia; mm sss stop.
    + exists Q; split; auto; split; auto; intros v; split.
      * intros (s0 & H); revert H; apply P_imp_Q; simpl; lia.
      * intros (s0 & H); revert H; apply Q_imp_P; simpl; lia.
  Qed.

  Theorem mm_remove_self_loops_strong : { Q |  mm_no_self_loops (1,Q)
                                     /\ (forall i x j, (i,DEC x j::nil) <sc (1,Q) -> j < 1+length Q)
                                     /\ (forall v w, (exists j, (1,P) // (1,v) ~~> (j, w)) -> (exists j, (1,Q) // (1,0##v) ~~> (j, 0 ## w)))
                                     /\ (forall v,  (1,Q) // (1,0##v) ↓ -> (1,P) // (1,v) ↓)}.
  Proof.
    destruct (eq_nat_dec lP 0) as [ HlP | HlP ].
    + exists nil.
      split; [ | split ].
      - intros i rho ([ | ] & ? & ? & ?); discriminate.
      - intros i x j ([ | ] & ? & ? & ?); discriminate.
      - destruct P; try discriminate.
        split.
        * exists 1. split; simpl; try lia; mm sss stop.
          destruct H as [j [[i Hj] ?]].
          eapply sss_steps_stall in Hj as [_ [=]]. 2:cbn; lia. now subst.
        * intros v [(j, w) H]. exists (1,v);split; simpl; try lia; mm sss stop.
    + exists Q. split; auto; split; auto; split.
      * intros v w [j H]. exists 0.
        eapply (@P_imp_Q_strong (1,v) (j,w)); simpl; try lia; eauto.
      * intros v (s0 & H); revert H; apply Q_imp_P; simpl; lia.
  Qed.

  Theorem mm_remove_self_loops_strong' : { Q |  mm_no_self_loops (1,Q)
                                     /\ (forall i x j, (i,DEC x j::nil) <sc (1,Q) -> j < 1+length Q)
                                     /\ forall v w, (exists j, (1,P) // (1,v) ~~> (j, w)) <-> (exists j, (1,Q) // (1,0##v) ~~> (j, 0 ## w)) }.
  Proof.
    destruct (eq_nat_dec lP 0) as [ HlP | HlP ].
    + exists nil.
      split; [ | split ].
      - intros i rho ([ | ] & ? & ? & ?); discriminate.
      - intros i x j ([ | ] & ? & ? & ?); discriminate.
      - destruct P; try discriminate.
        split.
        * exists 1. split; simpl; try lia; mm sss stop.
          destruct H as [j [[i Hj] ?]].
          eapply sss_steps_stall in Hj as [_ [=]]. 2:cbn; lia. now subst.
        * exists 1. split; simpl; try lia; mm sss stop.
          destruct H as [j [[i Hj] ?]].
          eapply sss_steps_stall in Hj as [_ ? % (f_equal snd) % (f_equal (@vec_tail _ _))]. cbn in H0. congruence.
          cbn; lia.
    + exists Q; split; auto; split; auto; intros v; split.
      * intros [j H]. exists 0.
        eapply (@P_imp_Q_strong (1,v) (j,w)); simpl; try lia; eauto.
      * intros [j H].
        destruct (@Q_imp_P (1, 0 ## v) (j, 0 ## w)) as [[j' w'] H2]; eauto.
        -- simpl; lia.
        -- exists j'. cbn in H2. enough (w' = w) as <- by eauto.
           eapply P_imp_Q_strong in H2.
           2: simpl; lia. cbn in H2.
           destruct H2 as [H2 ?]. destruct H as [H ?].
           eapply sss_compute_fun in H; eauto.
           eapply (f_equal snd) in H.
           cbn in H.
           eapply (f_equal (@vec_tail _ _)) in H.
           exact H. eapply mm_sss_fun.
  Qed.

End remove_self_loops.