From Coq Require Import List Arith Lia Permutation Wf_nat.
Import ListNotations.

From Undecidability.Shared.Libs.DLW Require Import gcd prime.
From Undecidability.FRACTRAN Require Import FRACTRAN fractran_utils.

Set Default Goal Selector "!".

(* necessary facts on prime factorization *)
Module Prime_factors.

#[local] Notation lprod := (fold_right mult 1).

Lemma prime_divides_lt {lc ld} :
  ~ (divides (lprod ld) (lprod lc)) ->
  Forall prime lc -> Forall prime ld ->
  exists (p : nat), prime p /\ count_occ Nat.eq_dec lc p < count_occ Nat.eq_dec ld p.
Proof.
  revert lc. induction ld as [|a ld IHld].
  - intros lc H. exfalso. apply H.
    exists (lprod lc). cbn. lia.
  - intros lc H Hlc Hld'.
    pose proof (Ha := Forall_inv Hld').
    pose proof (Hld := Forall_inv_tail Hld').
    destruct (in_dec Nat.eq_dec a lc) as [Halc|Halc].
    + apply in_split in Halc as [l1c [l2c ?]]. subst lc.
      assert (H' : not (divides (lprod (ld)) (lprod (l1c ++ l2c)))).
      { intros [p Hp]. rewrite !lprod_app in *.
        apply H. exists p. cbn. nia. }
      assert (H'lc : Forall prime (l1c ++ l2c)).
      { revert Hlc. rewrite !Forall_app.
        now intros [? ? %Forall_inv_tail]. }
      specialize (IHld _ H' H'lc Hld).
      destruct IHld as [p [? Hp]].
      exists p. split; [assumption|].
      revert Hp. rewrite !count_occ_app. cbn.
      destruct (Nat.eq_dec); lia.
    + exists a. split; [assumption|].
      apply (count_occ_not_In Nat.eq_dec) in Halc.
      rewrite count_occ_cons_eq, Halc; lia.
Qed.

Definition count_pow (p n : nat) : nat :=
  let (l, _) := (@prime_decomp (S n) (Nat.neq_succ_0 n))
    in count_occ Nat.eq_dec l p.

Lemma prime_divides_lt' {c d} (Hc : c <> 0) (Hd : d <> 0):
  ~ (divides d c) ->
  exists p,
    (forall x y, (S x) * c = (S y) * d -> count_pow p y < count_pow p x).
Proof.
  pose proof (@prime_decomp c Hc) as [lc [Hclc Hlc]].
  pose proof (@prime_decomp d Hd) as [ld [Hdld Hld]].
  subst. intros H. apply prime_divides_lt in H as [p [? Hp]]; [|assumption ..].
  exists p. intros x y. unfold count_pow.
  destruct (@prime_decomp (S x) _) as [lx [Hxlx Hlx]].
  destruct (@prime_decomp (S y) _) as [ly [Hyly Hly]].
  rewrite Hxlx, Hyly, <- !lprod_app.
  intros E. apply prime_decomp_uniq in E; [|now rewrite Forall_app ..].
  assert (iffLR : forall P Q, (P <-> Q) -> P -> Q) by tauto.
  assert (H' := iffLR _ _ (Permutation_count_occ Nat.eq_dec _ _) E p).
  rewrite !count_occ_app in H'. lia.
Qed.

Lemma rel_prime_intro {p q} : (p <> 0 \/ q <> 0) ->
  { a & { b & { g | p = a*g /\ q = b*g /\ is_gcd a b 1 } } }.
Proof.
  intros ?. assert (Hg := gcd_spec p q).
  assert (gcd p q <> 0).
  { intros H'g. rewrite H'g in Hg. apply is_gcd_0 in Hg. tauto. }
  destruct (divides_dec p (gcd p q)) as [[a Ha]|].
  2: { unfold is_gcd in Hg. tauto. }
  destruct (divides_dec q (gcd p q)) as [[b Hb]|].
  2: { unfold is_gcd in Hg. tauto. }
  exists a, b, (gcd p q). split; [easy|split;[easy|]].
  split; [apply divides_1|]. split; [apply divides_1|].
  intros [|[|k]].
  - intros [??] [??]. nia.
  - intros _ _. now exists 1.
  - intros [ka ?] [kb ?]. subst a b. exfalso.
    destruct Hg as [[??] [[??] Hpq]].
    destruct (Hpq (S (S k) * (gcd p q))) as [k' ?].
    + exists ka. nia.
    + exists kb. nia.
    + destruct k' as [|?]; nia.
Qed.

End Prime_factors.

Import Prime_factors.

Module Argument.

Lemma fractran_nstop_cons a b l s :
  (forall t, ~ l /F/ t ↓) -> ~ (a,b) :: l /F/ s ↓.
Proof.
  intros H [u [[n Hsu] Hu]].
  destruct (divides_dec (a*u) b) as [[t Ht]|?].
  - apply (Hu t), in_fractran_0. lia.
  - apply (H u). exists u.
    split; [now exists 0|].
    intros t Hut. now apply (Hu t), in_fractran_1.
Qed.

Lemma fractran_nstop_zero_num_1 d l s : ~ (0,d) :: l /F/ s ↓.
Proof.
  destruct d as [|d]; simpl; intros [y [_ Hs]]; apply (Hs 0); now constructor.
Qed.

Lemma fractran_stop_zero_den_1 c s (Hc : c <> 0) : [(c, 0)] /F/ s ↓.
Proof.
  destruct s as [|s]; simpl.
  - exists 1. constructor.
    + exists 1. exists 1. constructor; [|reflexivity].
      now constructor.
    + intros z [?|[? Hz]]%fractran_step_cons_inv; [lia|inversion Hz].
  - exists (S s). constructor.
    + now exists 0.
    + intros z [?|[? Hz]]%fractran_step_cons_inv; [lia|inversion Hz].
Qed.

Lemma fractran_stop_ndiv_singleton x c d (Hc : c <> 0) (Hd : d <> 0) :
  ~ divides d c -> [(c,d)] /F/ (S x) ↓.
Proof.
  intros [p H]%(prime_divides_lt' Hc Hd).
  induction x as [x IH] using (induction_ltof1 _ (fun x => (count_pow p x))); unfold ltof in IH.
  destruct (fractran_step_dec [(c,d)] (S x)) as [[y Hxy]|Hs].
  - revert Hxy. intros [|[? Hxy]]%fractran_step_cons_inv.
    + destruct y as [|y]; [lia|].
      specialize (H x y ltac:(lia)).
      apply IH in H as [y' [[n Hyy'] Hs']].
      exists y'. split; [|exact Hs'].
      exists (1+n), (S y). now split; [constructor|].
    + inversion Hxy.
  - exists (S x). now split; [exists 0|].
Qed.

(* if the second fraction is not redundant, then the program is not reversible *)
Lemma fractran_step_contradict_reversible a b c d l :
  is_gcd b a 1 -> ~ divides b d ->
  exists (s t u : nat),
    (a,b) :: (c,d) :: l /F/ s ≻ u /\ (a,b) :: (c,d) :: l /F/ t ≻ u /\ s <> t.
Proof.
  intros Hba Hbd. exists (c*b), (a*d), (a*c).
  constructor; [constructor; lia|].
  constructor.
  - apply in_fractran_1.
    + intros Hb. now do 2 apply (is_rel_prime_div _ Hba) in Hb.
    + constructor. lia.
  - intros E. apply Hbd. apply (is_rel_prime_div _ Hba). now exists c.
Qed.

Lemma fractran_step_iff_halt l1 l2 :
  (forall s t, l1 /F/ s ≻ t <-> l2 /F/ s ≻ t) -> (forall x, l1 /F/ x ↓ -> l2 /F/ x ↓).
Proof.
  intros H x. intros [y [[n Hn] Hs]]. exists y. constructor.
  - exists n. revert x Hn. induction n as [|n IHn]; simpl; auto.
    intros x [y' [Hy' Hs']]. exists y'. constructor; [now apply H|now apply IHn].
  - intros z Hs'. now apply (Hs z), H.
Qed.

Lemma fractran_step_iff_decide {l1 l2 n} :
  (forall s t, l1 /F/ s ≻ t <-> l2 /F/ s ≻ t) ->
  ((l1 /F/ n ↓) + (not (l1 /F/ n ↓))) ->
  ((l2 /F/ n ↓) + (not (l2 /F/ n ↓))).
Proof.
  intros H [|Hn]; [left|right].
  - eapply fractran_step_iff_halt; eassumption.
  - intros ?. apply Hn. eapply fractran_step_iff_halt; [|eassumption].
    firstorder easy.
Qed.

(* in a reversible FRACTRAN program the second fraction is shadowed by the first *)
Lemma fractran_reversible_shadow {a b c d P x y} : x <> 0 -> y <> 0 ->
  fractran_reversible ((a * x, b * x) :: (c * y, d * y) :: P) ->
  is_gcd b a 1 -> is_gcd d c 1 ->
  forall s t, (c * y) * s = t * (d * y) -> exists u, (a * x) * s = u * (b * x).
Proof.
  intros ?? HP Hba Hdc.
  destruct (divides_dec d b) as [[u Hu]|Hb].
  - subst d. intros s t Hst.
    assert (Hubcs : divides (u * b) (c * s)) by (exists t; nia).
    destruct (is_rel_prime_div s Hdc Hubcs) as [k ?].
    subst s. exists (a*k*u). nia.
  - exfalso.
    destruct (fractran_step_contradict_reversible a b c d P Hba Hb) as [s [t [u [? [? Hst]]]]].
    apply Hst.
    enough (H_extend : forall s' t', (a, b) :: (c, d) :: P /F/ s' ≻ t' ->
      (a * x, b * x) :: (c * y, d * y) :: P /F/ s' ≻ t').
    { apply (HP s t u); now apply H_extend. }
    intros s' t' [|[H'b Hs't']]%fractran_step_cons_inv.
    + apply in_fractran_0. nia.
    + revert Hs't'. intros [|[H'd Hs't']]%fractran_step_cons_inv.
      * apply in_fractran_1.
        { intros [k ?]. apply H'b. exists k. nia. }
        apply in_fractran_0. nia.
      * apply in_fractran_1.
        { intros [k1 ?]. apply H'b. exists k1. nia. }
        apply in_fractran_1.
        { intros [k2 ?]. apply H'd. exists k2. nia. }
        exact Hs't'.
Qed.

Lemma fractran_reversible_shorten {a b c d P s t} :
  fractran_reversible ((S a, b) :: (S c, d) :: P) ->
  ((S a, b) :: P /F/ s ≻ t) <-> ((S a, b) :: (S c, d) :: P /F/ s ≻ t).
Proof.
  intros HP.
  assert (Hba : b <> 0 \/ S a <> 0) by lia.
  destruct (rel_prime_intro Hba) as [b' [a' [gab [H'b [H'a Hb'a']]]]].
  rewrite H'b, H'a in *.
  assert (Hdc : d <> 0 \/ S c <> 0) by lia.
  destruct (rel_prime_intro Hdc) as [d' [c' [gcd [H'd [H'c Hd'c']]]]].
  rewrite H'd, H'c in *.
  assert (Hgab : gab <> 0) by lia.
  assert (Hgcd : gcd <> 0) by lia.
  split.
  + intros [?|[Hb ?]]%fractran_step_cons_inv.
    * now apply in_fractran_0.
    * apply in_fractran_1; [easy|].
      apply in_fractran_1; [|easy].
      intros [m Hm]. apply Hb.
      eapply (fractran_reversible_shadow Hgab Hgcd HP Hb'a' Hd'c').
      eassumption.
  + intros [?|[Hb H']]%fractran_step_cons_inv.
    * now apply in_fractran_0.
    * revert H'. intros [H'|[Hd ?]]%fractran_step_cons_inv.
      ** exfalso. apply Hb. eapply (fractran_reversible_shadow Hgab Hgcd HP Hb'a' Hd'c' s t). lia.
      ** now apply in_fractran_1.
Qed.

(* informative decision statement for empty FRACTRAN halting *)
Lemma fractran_empty_decision (n: nat) : ([] /F/ n ↓).
Proof.
  exists n. split; [now exists 0|].
  intros z H. now inversion H.
Qed.

(* informative decision statement for singleton FRACTRAN halting *)
Lemma fractran_singleton_decision c d n : ([(c,d)] /F/ n ↓) + (not ([(c,d)] /F/ n ↓)).
Proof.
  destruct (divides_dec c d) as [[k Hk] | Hndiv].
  { right. intros [y [[m Hm] Hstop]]. apply (Hstop (k*y)). constructor. nia. }
  destruct c as [|c].
  { right. now intros H%fractran_nstop_zero_num_1. }
  destruct d as [|d].
  { left. now apply fractran_stop_zero_den_1. }
  destruct n as [|n].
  { right. intros [y [[n Hn] Hy]].
    apply fractran_rt_no_zero_den in Hn.
    - apply (Hy 0). apply in_fractran_0. lia.
    - now repeat constructor. }
  left. now apply fractran_stop_ndiv_singleton.
Qed.

(* informative decision statement for reversible FRACTRAN halting *)
Theorem decision (P : list (nat * nat)) (n: nat) : fractran_reversible P -> (P /F/ n ↓) + (not (P /F/ n ↓)).
Proof.
  induction P as [P IH] using (induction_ltof1 _ (fun P => length P)); unfold ltof in IH.
  destruct P as [|(a,b) [|(c,d) P]].
  - (* empty program *)
    intros _. left. now apply fractran_empty_decision.
  - (* singleton program *)
    intros _. now apply fractran_singleton_decision.
  - (* at least two fractions, remove the second *)
    destruct a as [|a]; simpl.
    { intros _. right. now intros H%fractran_nstop_zero_num_1. }
    destruct c as [|c]; simpl.
    { intros _. right. now apply fractran_nstop_cons, fractran_nstop_zero_num_1. }
    intros HP.
    enough (H'P : forall s t, ((S a, b) :: P) /F/ s ≻ t <-> ((S a, b) :: (S c, d) :: P) /F/ s ≻ t).
    { apply (fractran_step_iff_decide H'P).
      apply IH; simpl; [lia|].
      intros n1 n2 m Hn1%H'P Hn2%H'P. eapply HP; eassumption. }
    intros s t. now apply fractran_reversible_shorten.
Qed.

End Argument.

Require Import Undecidability.Synthetic.Definitions.

(* decision procedure for the halting problem for reversible FRACTRAN *)
Definition decide : { P : list (nat * nat) | fractran_reversible P } * nat -> bool :=
  fun '(exist _ P HP, x) =>
    match Argument.decision P x HP with
    | inl _ => true
    | inr _ => false
    end.

(* decision procedure correctness *)
Lemma decide_spec : decider decide Halt_REV_FRACTRAN.
Proof.
  intros [[P HP] x]. unfold reflects. simpl.
  destruct (Argument.decision P x HP) as [[y Hy%eval_iff]|HPx].
  - firstorder easy.
  - split; [|easy]. intros [y ?%eval_iff]. firstorder easy.
Qed.


(** attempted 4 and completed 4 out of 4 optional exercises *)
(** attempted 3 and completed 3 out of 3 advanced exercises *)
(** Exercise 1 (snd_fst_is_swap) *)
Theorem snd_fst_is_swap : forall (p : natprod),
  (snd p, fst p) = swap_pair p.
Proof.
  intros p. destruct p as (n, m). reflexivity.  Qed.

(** Exercise 2 (optional (fst_swap_is_snd) *)
Theorem fst_swap_is_snd : forall (p : natprod),
  fst (swap_pair p) = snd p.
Proof.
  intros p. destruct p as (n, m). reflexivity.  Qed.

(** Exercise 3 (list_funs) *)
ixpoint nonzeros (l:natlist) : natlist :=
  match l with
  | nil => nil
  | O :: t => nonzeros t
  | h :: t => h :: (nonzeros t)
  end.
Example test_nonzeros:          nonzeros [0;1;0;2;3;0;0] = [1;2;3].
Proof. reflexivity.  Qed.
Fixpoint oddmembers (l:natlist) : natlist :=
  match l with
  | nil => nil
  | h :: t => match oddb h with
              | true => h :: (oddmembers t)
              | false => oddmembers t
              end
  end.

Example test_oddmembers:        oddmembers [0;1;0;2;3;0;0] = [1;3].
Proof. reflexivity.  Qed.

Fixpoint countoddmembers (l:natlist) : nat :=
  length (oddmembers l).

Example test_countoddmembers1:  countoddmembers [1;0;3;1;4;5] = 4.
Proof. reflexivity.  Qed.
Example test_countoddmembers2:  countoddmembers [0;2;4] = 0.
Proof. reflexivity.  Qed.
Example test_countoddmembers3:  countoddmembers nil = 0.
Proof. reflexivity.  Qed.

(** Exercise 4 (advanced (alternate)) *)
Fixpoint alternate (l1 l2 : natlist) : natlist :=
  match l1, l2 with
  | nil, l2' => l2'
  | l1', nil => l1'
  | h1 :: t1, h2 :: t2 => h1 :: h2 :: (alternate t1 t2)
  end.

Example test_alternate1:        alternate [1;2;3] [4;5;6] = [1;4;2;5;3;6].
Proof. reflexivity.  Qed.
Example test_alternate2:        alternate [1] [4;5;6] = [1;4;5;6].
Proof. reflexivity.  Qed.
Example test_alternate3:        alternate [1;2;3] [4] = [1;4;2;3].
Proof. reflexivity.  Qed.
Example test_alternate4:        alternate [] [20;30] = [20;30].
Proof. reflexivity.  Qed.

(** Exercise 5 (bag_functions) *)
Fixpoint count (v:nat) (s:bag) : nat :=
  match s with
  | nil => O
  | h :: t => match (beq_nat h v) with
              | true => S (count v t)
              | false => count v t
              end
  end.
Example test_count1:              count 1 [1;2;3;1;4;1] = 3.
Proof. reflexivity.  Qed.
Example test_count2:              count 6 [1;2;3;1;4;1] = 0.
Proof. reflexivity.  Qed.

(** Exercise 6 (bag functions) *)
Definition sum : bag -> bag -> bag :=
  app.

Example test_sum1:              count 1 (sum [1;2;3] [1;4;1]) = 3.
Proof. reflexivity.  Qed.

Definition add (v:nat) (s:bag) : bag :=
  v :: s.

Example test_add1:                count 1 (add 1 [1;4;1]) = 3.
Proof. reflexivity.  Qed.
Example test_add2:                count 5 (add 1 [1;4;1]) = 0.
Proof. reflexivity.  Qed.

Definition member (v:nat) (s:bag) : bool :=
  match count v s with
  | O   => false
  | S _ => true
  end.

Example test_member1:             member 1 [1;4;1] = true.
Proof. reflexivity.  Qed.
Example test_member2:             member 2 [1;4;1] = false.
Proof. reflexivity.  Qed.

(** Exercise 7 (optional (bag_more_functions)) *)
Fixpoint remove_one (v:nat) (s:bag) : bag :=
  (* When remove_one is applied to a bag without the number to remove,
     it should return the same bag unchanged. *)
  match s with
  | nil => nil
  | h :: t => match beq_nat h v with
              | true => t
              | false => h :: (remove_one v t)
              end
  end.
Example test_remove_one1:         count 5 (remove_one 5 [2;1;5;4;1]) = 0.
Proof. reflexivity.  Qed.
Example test_remove_one2:         count 5 (remove_one 5 [2;1;4;1]) = 0.
Proof. reflexivity.  Qed.
Example test_remove_one3:         count 4 (remove_one 5 [2;1;4;5;1;4]) = 2.
Proof. reflexivity.  Qed.
Example test_remove_one4:         count 5 (remove_one 5 [2;1;5;4;5;1;4]) = 1.
Proof. reflexivity.  Qed.
Fixpoint remove_all (v:nat) (s:bag) : bag :=
  match s with
  | nil => nil
  | h :: t => match beq_nat h v with
              | true => remove_all v t
              | false => h :: (remove_all v t)
              end
  end.

Example test_remove_all1:          count 5 (remove_all 5 [2;1;5;4;1]) = 0.
Proof. reflexivity.  Qed.
Example test_remove_all2:          count 5 (remove_all 5 [2;1;4;1]) = 0.
Proof. reflexivity.  Qed.
Example test_remove_all3:          count 4 (remove_all 5 [2;1;4;5;1;4]) = 2.
Proof. reflexivity.  Qed.
Example test_remove_all4:          count 5 (remove_all 5 [2;1;5;4;5;1;4;5;1;4]) = 0.
Proof. reflexivity.  Qed.

Fixpoint subset (s1:bag) (s2:bag) : bool :=
  match s1 with
  | nil => true
  | h :: t => match member h s2 with
              | true => subset t (remove_one h s2)
              | false => false
              end
  end.

Example test_subset1:              subset [1;2] [2;1;4;1] = true.
Proof. reflexivity.  Qed.
Example test_subset2:              subset [1;2;2] [2;1;4;1] = false.
Proof. reflexivity.  Qed.

(** Exercise 8 (bag_theorem) *)
Theorem beq_nat_refl: forall n : nat,
  beq_nat n n = true.
Proof.
  intros n. induction n as [| n'].
  Case "n = 0".
    reflexivity.
  Case "n = S n'".
    simpl. rewrite -> IHn'. reflexivity.  Qed.

Theorem add_count: forall (n : nat) (s : bag),
  count n (add n s) = S (count n s).
Proof.
  intros n s. destruct s as [| m l'].
  Case "s = nil".
    simpl. rewrite -> beq_nat_refl. reflexivity.
  Case "s = cons".
    simpl. rewrite -> beq_nat_refl. reflexivity.  Qed.

(** Exercise 9 (list_exercises) *)
Theorem app_nil_end : forall l : natlist,
  l ++ [] = l.
Proof.
  intros l. induction l as [| n l'].
  Case "l = nil".
    reflexivity.
  Case "l = cons".
    simpl. rewrite -> IHl'. reflexivity.  Qed.

Theorem rev_snoc: forall n : nat, forall l : natlist,
  rev (snoc l n) = n :: rev l.
Proof.
  intros n l. induction l as [| m l'].
  Case "l = nil".
    reflexivity.
  Case "l = cons".
    simpl. rewrite -> IHl'. reflexivity.  Qed.

Theorem rev_involutive : forall l : natlist,
  rev (rev l) = l.
Proof.
  intros l. induction l as [| n l'].
  Case "l = nil".
    reflexivity.
  Case "l = cons".
    simpl. rewrite -> rev_snoc. rewrite -> IHl'. reflexivity.  Qed.
Theorem app_ass4 : forall l1 l2 l3 l4 : natlist,
  l1 ++ (l2 ++ (l3 ++ l4)) = ((l1 ++ l2) ++ l3) ++ l4.
Proof.
  intros l1 l2 l3 l4.
  rewrite -> app_ass. rewrite -> app_ass. reflexivity.  Qed.

Theorem snoc_append : forall (l:natlist) (n:nat),
  snoc l n = l ++ [n].
Proof.
  intros l n. induction l as [| m l'].
  Case "l = nil".
    reflexivity.
  Case "l = cons".
    simpl. rewrite -> IHl'. reflexivity.  Qed.

Theorem distr_rev : forall l1 l2 : natlist,
  rev (l1 ++ l2) = (rev l2) ++ (rev l1).
Proof.
  intros l1 l2. induction l1 as [| n1 l1'].
  Case "l1 = nil".
    simpl. rewrite -> app_nil_end. reflexivity.
  Case "l1 = cons".
    simpl. rewrite -> snoc_append. rewrite -> snoc_append.
    rewrite -> IHl1'. rewrite -> app_ass. reflexivity.  Qed.
Lemma nonzeros_app : forall l1 l2 : natlist,
  nonzeros (l1 ++ l2) = (nonzeros l1) ++ (nonzeros l2).
Proof.
  intros l1 l2. induction l1 as [| n1 l1'].
  Case "l1 = nil".
    reflexivity.
  Case "l1 = cons".
    simpl. rewrite -> IHl1'.
    destruct n1 as [| n1'].
    SCase "n1 = O".
      reflexivity.
    SCase "n1 = S n1'".
      reflexivity.  Qed.

(** Exercise 10 (beq_natlist) *)
Fixpoint beq_natlist (l1 l2 : natlist) : bool :=
  match l1 with
  | h1 :: t1 => match l2 with
                | h2 :: t2 => andb (beq_nat h1 h2) (beq_natlist t1 t2)
                | nil => false
                end
  | nil      => match l2 with
                | h2 :: t2 => false
                | nil => true
                end
  end.

Example test_beq_natlist1 :   (beq_natlist nil nil = true).
  Proof. reflexivity.  Qed.
Example test_beq_natlist2 :   beq_natlist [1;2;3] [1;2;3] = true.
  Proof. reflexivity.  Qed.
Example test_beq_natlist3 :   beq_natlist [1;2;3] [1;2;4] = false.
  Proof. reflexivity.  Qed.
Theorem beq_natlist_refl : forall l:natlist,
  true = beq_natlist l l.
Proof.
  intros l. induction l as [| l'].
  Case "l = nil".
    reflexivity.
  Case "l = cons".
    simpl. rewrite <- IHl. rewrite <- beq_nat_refl. simpl. reflexivity.
  Qed.

(** Exercise 11 (list_design) *)
Theorem cons_snoc_append: forall (n1 n2 : nat), forall l : natlist,
  [n1] ++ (snoc l n2) = (cons n1 l) ++ [n2].
Proof.
  intros n1 n2 l. simpl. rewrite -> snoc_append. reflexivity.  Qed.

(** Exercise 12 (advanced (bag_proofs)) *)
Theorem count_member_nonzero : forall (s : bag),
  ble_nat 1 (count 1 (1 :: s)) = true.
Proof.
  intros s.
  simpl. reflexivity. Qed.
Theorem remove_decreases_count: forall (s : bag),
  ble_nat (count 0 (remove_one 0 s)) (count 0 s) = true.
Proof.
  intros s. induction s as [|n s'].
  Case "s = nil".
    simpl. reflexivity.
  Case "s = cons".
    simpl. destruct n.
    SCase "n = 0".
      simpl. rewrite ble_n_Sn. reflexivity.
    SCase "n = S n'".
      simpl. rewrite IHs'. reflexivity.
  Qed.

(** Exercise 13 (optional (bag_count_sum)) *)
Theorem bag_count_sum: forall n : nat, forall s1 s2 : bag,
  count n (sum s1 s2) = (count n s1) + (count n s2).
Proof.
  intros n s1 s2. induction s1 as [| m s1'].
  Case "s1 = nil".
    reflexivity.
  Case "s1 = cons".
    simpl. rewrite -> IHs1'.
    remember (beq_nat m n) as eq.
    destruct eq.
    SCase "eq = true".
      reflexivity.
    SCase "eq = false".
      reflexivity.  Qed.

(** Exercise 14 (advanced (rev_injective)) *)
Theorem rev_injective: forall l1 l2 : natlist,
  rev l1 = rev l2 -> l1 = l2.
Proof.
  intros l1 l2 H.
  rewrite <- rev_involutive.
  rewrite <- H.
  rewrite -> rev_involutive.
  reflexivity.  Qed.

(** Exercise 15 (hd_opt) *)
Definition hd_opt (l : natlist) : natoption :=
  match l with
  | h :: t => Some h
  | nil => None
  end.

Example test_hd_opt1 : hd_opt [] = None.
 Proof. reflexivity.  Qed.

Example test_hd_opt2 : hd_opt [1] = Some 1.
 Proof. reflexivity.  Qed.

Example test_hd_opt3 : hd_opt [5;6] = Some 5.
 Proof. reflexivity.  Qed.

(** Exercise 16 (optional (option_elim_hd)) *)
Theorem option_elim_hd : forall (l:natlist) (default:nat),
  hd default l = option_elim default (hd_opt l).
Proof.
  intros l default. destruct l as [| n l'].
  Case "l = nil".
    reflexivity.
  Case "l = cons".
    reflexivity.  Qed.

(** Exercise 17 (dictionary_invariant1) *)
Theorem dictionary_invariant1' : forall (d : dictionary) (k v: nat),
  (find k (insert k v d)) = Some v.
Proof.
  intros d k v. simpl. rewrite <- beq_nat_refl. reflexivity.
  Qed.

(** Exercise 18 (dictionary_invariant2) *)
Theorem dictionary_invariant2' : forall (d : dictionary) (m n o: nat),
  beq_nat m n = false -> find m d = find m (insert n o d).
Proof.
  intros d m n o h.
  simpl. rewrite h. reflexivity. Qed.


Require Import BinInt.
From mathcomp Require Import all_ssreflect all_algebra.
Require Import tactics binomialz rat_of_Z seq_defs.
Require harmonic_numbers.

Local Open Scope ring_scope.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(* We state the equalities and prove evaluations of the main sequences
   a and b, to be used as initial conditions. Proofs are done by
   (internal) computation, using the field tactic so that computations
   are performed using a rather efficient binary arithmetic instead of
   type rat which is awful for 'large' scale computations.*)

(* A tactic to unroll the definition of a and preprocess the term in order *)
(* for rat_field to be able to process the equality correctly. *)
Ltac expand_a :=
(* unfolding the definition of a, c, binomials and unlocking the constant *)
(* defining the sigma, so that sums can be unrolled: *)
rewrite /a /c /binomialz unlock /=.

(* A tactic to unroll the definition of b and preprocess the term in order *)
(* for rat_field to be able to process the equality correctly. *)
Ltac expand_b :=
(* unfolding the definition of b: *)
rewrite /b;
(* unfolding the definition of auxiliary sequence and unlocking the constant*)
(* defining the sigma, so that sums can be unrolled: *)
rewrite unlock /= /v /c /u /ghn3 /harmonic_numbers.ghn;
rewrite unlock /= /s unlock /= /d /binomialz /=;
(* normalizing the exponents (that are natural numbers) *)
rewrite ?(=^~ PoszD, addnE) /=.

(* Tactic proving an evaluation for the sequence a (fails otherwise) *)
Ltac solve_a_evaluation := by expand_a; field.

(* Tactic proving an evaluation for the sequence b (fails otherwise) *)
Ltac solve_b_evaluation := by expand_b; field.

(* Evaluations for the sequence b. With our definition we have:
        b_n = 0, 6, 351/4, 62531/36, ... *)

Lemma b0_eq : b 0 = 0.
Proof. solve_b_evaluation. Qed.

Lemma b1_eq : b 1 = 6%:Q.
Proof. solve_b_evaluation. Qed.

Lemma b2_eq : b 2 = rat_of_Z 351 / rat_of_Z 4.
Proof. solve_b_evaluation. Qed.

Lemma b3_eq : b 3 = rat_of_Z 62531 / rat_of_Z 36.
Proof. solve_b_evaluation. Qed.

(* Evaluations for the sequence b. With our definition we have:
     a_n = 1, 5, 73, 1445, 33001 ... *)

Lemma a0_eq : a 0 = 1.
Proof. solve_a_evaluation. Qed.

Lemma a1_eq : a 1 = rat_of_Z 5.
Proof. solve_a_evaluation. Qed.

Lemma a2_eq : a 2 = rat_of_Z 73.
Proof. solve_a_evaluation. Qed.

Lemma a3_eq : a 3 = rat_of_Z 1445.
Proof. solve_a_evaluation. Qed.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Correctness of instruction selection for integer division *)

Require Import Zquot Coqlib.
Require Import AST Integers Floats Values Memory Globalenvs Events.
Require Import Cminor Op CminorSel.
Require Import SelectOp SelectOpproof SplitLong SplitLongproof SelectLong SelectLongproof SelectDiv.

Local Open Scope cminorsel_scope.

(** * Main approximation theorems *)

Section Z_DIV_MUL.

Variable N: Z.      (**r number of relevant bits *)
Hypothesis N_pos: N >= 0.
Variable d: Z.      (**r divisor *)
Hypothesis d_pos: d > 0.

(** This is theorem 4.2 from Granlund and Montgomery, PLDI 1994. *)

Lemma Zdiv_mul_pos:
  forall m l,
  l >= 0 ->
  two_p (N+l) <= m * d <= two_p (N+l) + two_p l ->
  forall n,
  0 <= n < two_p N ->
  Zdiv n d = Zdiv (m * n) (two_p (N + l)).
Proof.
  intros m l l_pos [LO HI] n RANGE.
  exploit (Z_div_mod_eq n d). auto.
  set (q := n / d).
  set (r := n mod d).
  intro EUCL.
  assert (0 <= r <= d - 1).
    unfold r. generalize (Z_mod_lt n d d_pos). omega.
  assert (0 <= m).
    apply Zmult_le_0_reg_r with d. auto.
    exploit (two_p_gt_ZERO (N + l)). omega. omega.
  set (k := m * d - two_p (N + l)).
  assert (0 <= k <= two_p l).
    unfold k; omega.
  assert ((m * n - two_p (N + l) * q) * d = k * n + two_p (N + l) * r).
    unfold k. rewrite EUCL. ring.
  assert (0 <= k * n).
    apply Zmult_le_0_compat; omega.
  assert (k * n <= two_p (N + l) - two_p l).
    apply Zle_trans with (two_p l * n).
    apply Zmult_le_compat_r. omega. omega.
    replace (N + l) with (l + N) by omega.
    rewrite two_p_is_exp.
    replace (two_p l * two_p N - two_p l)
       with (two_p l * (two_p N - 1))
         by ring.
    apply Zmult_le_compat_l. omega. exploit (two_p_gt_ZERO l). omega. omega.
    omega. omega.
  assert (0 <= two_p (N + l) * r).
    apply Zmult_le_0_compat.
    exploit (two_p_gt_ZERO (N + l)). omega. omega.
    omega.
  assert (two_p (N + l) * r <= two_p (N + l) * d - two_p (N + l)).
    replace (two_p (N + l) * d - two_p (N + l))
       with (two_p (N + l) * (d - 1)) by ring.
    apply Zmult_le_compat_l.
    omega.
    exploit (two_p_gt_ZERO (N + l)). omega. omega.
  assert (0 <= m * n - two_p (N + l) * q).
    apply Zmult_le_reg_r with d. auto.
    replace (0 * d) with 0 by ring.  rewrite H2. omega.
  assert (m * n - two_p (N + l) * q < two_p (N + l)).
    apply Zmult_lt_reg_r with d. omega.
    rewrite H2.
    apply Zle_lt_trans with (two_p (N + l) * d - two_p l).
    omega.
    exploit (two_p_gt_ZERO l). omega. omega.
  symmetry. apply Zdiv_unique with (m * n - two_p (N + l) * q).
  ring. omega.
Qed.

Lemma Zdiv_unique_2:
  forall x y q, y > 0 -> 0 < y * q - x <= y -> Zdiv x y = q - 1.
Proof.
  intros. apply Zdiv_unique with (x - (q - 1) * y). ring.
  replace ((q - 1) * y) with (y * q - y) by ring. omega.
Qed.

Lemma Zdiv_mul_opp:
  forall m l,
  l >= 0 ->
  two_p (N+l) < m * d <= two_p (N+l) + two_p l ->
  forall n,
  0 < n <= two_p N ->
  Zdiv n d = - Zdiv (m * (-n)) (two_p (N + l)) - 1.
Proof.
  intros m l l_pos [LO HI] n RANGE.
  replace (m * (-n)) with (- (m * n)) by ring.
  exploit (Z_div_mod_eq n d). auto.
  set (q := n / d).
  set (r := n mod d).
  intro EUCL.
  assert (0 <= r <= d - 1).
    unfold r. generalize (Z_mod_lt n d d_pos). omega.
  assert (0 <= m).
    apply Zmult_le_0_reg_r with d. auto.
    exploit (two_p_gt_ZERO (N + l)). omega. omega.
  cut (Zdiv (- (m * n)) (two_p (N + l)) = -q - 1).
    omega.
  apply Zdiv_unique_2.
  apply two_p_gt_ZERO. omega.
  replace (two_p (N + l) * - q - - (m * n))
     with (m * n - two_p (N + l) * q)
       by ring.
  set (k := m * d - two_p (N + l)).
  assert (0 < k <= two_p l).
    unfold k; omega.
  assert ((m * n - two_p (N + l) * q) * d = k * n + two_p (N + l) * r).
    unfold k. rewrite EUCL. ring.
  split.
  apply Zmult_lt_reg_r with d. omega.
  replace (0 * d) with 0 by omega.
  rewrite H2.
  assert (0 < k * n). apply Zmult_lt_0_compat; omega.
  assert (0 <= two_p (N + l) * r).
    apply Zmult_le_0_compat. exploit (two_p_gt_ZERO (N + l)); omega. omega.
  omega.
  apply Zmult_le_reg_r with d. omega.
  rewrite H2.
  assert (k * n <= two_p (N + l)).
    rewrite Zplus_comm. rewrite two_p_is_exp; try omega.
    apply Zle_trans with (two_p l * n). apply Zmult_le_compat_r. omega. omega.
    apply Zmult_le_compat_l. omega. exploit (two_p_gt_ZERO l). omega. omega.
  assert (two_p (N + l) * r <= two_p (N + l) * d - two_p (N + l)).
    replace (two_p (N + l) * d - two_p (N + l))
       with (two_p (N + l) * (d - 1))
         by ring.
    apply Zmult_le_compat_l. omega. exploit (two_p_gt_ZERO (N + l)). omega. omega.
  omega.
Qed.

(** This is theorem 5.1 from Granlund and Montgomery, PLDI 1994. *)

Lemma Zquot_mul:
  forall m l,
  l >= 0 ->
  two_p (N+l) < m * d <= two_p (N+l) + two_p l ->
  forall n,
  - two_p N <= n < two_p N ->
  Z.quot n d = Zdiv (m * n) (two_p (N + l)) + (if zlt n 0 then 1 else 0).
Proof.
  intros. destruct (zlt n 0).
  exploit (Zdiv_mul_opp m l H H0 (-n)). omega.
  replace (- - n) with n by ring.
  replace (Z.quot n d) with (- Z.quot (-n) d).
  rewrite Zquot_Zdiv_pos by omega. omega.
  rewrite Z.quot_opp_l by omega. ring.
  rewrite Zplus_0_r. rewrite Zquot_Zdiv_pos by omega.
  apply Zdiv_mul_pos; omega.
Qed.

End Z_DIV_MUL.

(** * Correctness of the division parameters *)

Lemma divs_mul_params_sound:
  forall d m p,
  divs_mul_params d = Some(p, m) ->
  0 <= m < Int.modulus /\ 0 <= p < 32 /\
  forall n,
  Int.min_signed <= n <= Int.max_signed ->
  Z.quot n d = Zdiv (m * n) (two_p (32 + p)) + (if zlt n 0 then 1 else 0).
Proof with (try discriminate).
  unfold divs_mul_params; intros d m' p'.
  destruct (find_div_mul_params Int.wordsize
               (Int.half_modulus - Int.half_modulus mod d - 1) d 32)
  as [[p m] | ]...
  generalize (p - 32). intro p1.
  destruct (zlt 0 d)...
  destruct (zlt (two_p (32 + p1)) (m * d))...
  destruct (zle (m * d) (two_p (32 + p1) + two_p (p1 + 1)))...
  destruct (zle 0 m)...
  destruct (zlt m Int.modulus)...
  destruct (zle 0 p1)...
  destruct (zlt p1 32)...
  intros EQ; inv EQ.
  split. auto. split. auto. intros.
  replace (32 + p') with (31 + (p' + 1)) by omega.
  apply Zquot_mul; try omega.
  replace (31 + (p' + 1)) with (32 + p') by omega. omega.
  change (Int.min_signed <= n < Int.half_modulus).
  unfold Int.max_signed in H. omega.
Qed.

Lemma divu_mul_params_sound:
  forall d m p,
  divu_mul_params d = Some(p, m) ->
  0 <= m < Int.modulus /\ 0 <= p < 32 /\
  forall n,
  0 <= n < Int.modulus ->
  Zdiv n d = Zdiv (m * n) (two_p (32 + p)).
Proof with (try discriminate).
  unfold divu_mul_params; intros d m' p'.
  destruct (find_div_mul_params Int.wordsize
               (Int.modulus - Int.modulus mod d - 1) d 32)
  as [[p m] | ]...
  generalize (p - 32); intro p1.
  destruct (zlt 0 d)...
  destruct (zle (two_p (32 + p1)) (m * d))...
  destruct (zle (m * d) (two_p (32 + p1) + two_p p1))...
  destruct (zle 0 m)...
  destruct (zlt m Int.modulus)...
  destruct (zle 0 p1)...
  destruct (zlt p1 32)...
  intros EQ; inv EQ.
  split. auto. split. auto. intros.
  apply Zdiv_mul_pos; try omega. assumption.
Qed.

Lemma divs_mul_shift_gen:
  forall x y m p,
  divs_mul_params (Int.signed y) = Some(p, m) ->
  0 <= m < Int.modulus /\ 0 <= p < 32 /\
  Int.divs x y = Int.add (Int.shr (Int.repr ((Int.signed x * m) / Int.modulus)) (Int.repr p))
                         (Int.shru x (Int.repr 31)).
Proof.
  intros. set (n := Int.signed x). set (d := Int.signed y) in *.
  exploit divs_mul_params_sound; eauto. intros (A & B & C).
  split. auto. split. auto.
  unfold Int.divs. fold n; fold d. rewrite C by (apply Int.signed_range).
  rewrite two_p_is_exp by omega. rewrite <- Zdiv_Zdiv.
  rewrite Int.shru_lt_zero. unfold Int.add. apply Int.eqm_samerepr. apply Int.eqm_add.
  rewrite Int.shr_div_two_p. apply Int.eqm_unsigned_repr_r. apply Int.eqm_refl2.
  rewrite Int.unsigned_repr. f_equal.
  rewrite Int.signed_repr. rewrite Int.modulus_power. f_equal. ring.
  cut (Int.min_signed <= n * m / Int.modulus < Int.half_modulus).
  unfold Int.max_signed; omega.
  apply Zdiv_interval_1. generalize Int.min_signed_neg; omega. apply Int.half_modulus_pos.
  apply Int.modulus_pos.
  split. apply Zle_trans with (Int.min_signed * m). apply Zmult_le_compat_l_neg. omega. generalize Int.min_signed_neg; omega.
  apply Zmult_le_compat_r. unfold n; generalize (Int.signed_range x); tauto. tauto.
  apply Zle_lt_trans with (Int.half_modulus * m).
  apply Zmult_le_compat_r. generalize (Int.signed_range x); unfold n, Int.max_signed; omega. tauto.
  apply Zmult_lt_compat_l. generalize Int.half_modulus_pos; omega. tauto.
  assert (32 < Int.max_unsigned) by (compute; auto). omega.
  unfold Int.lt; fold n. rewrite Int.signed_zero. destruct (zlt n 0); apply Int.eqm_unsigned_repr.
  apply two_p_gt_ZERO. omega.
  apply two_p_gt_ZERO. omega.
Qed.

Theorem divs_mul_shift_1:
  forall x y m p,
  divs_mul_params (Int.signed y) = Some(p, m) ->
  m < Int.half_modulus ->
  0 <= p < 32 /\
  Int.divs x y = Int.add (Int.shr (Int.mulhs x (Int.repr m)) (Int.repr p))
                         (Int.shru x (Int.repr 31)).
Proof.
  intros. exploit divs_mul_shift_gen; eauto. instantiate (1 := x).
  intros (A & B & C). split. auto. rewrite C.
  unfold Int.mulhs. rewrite Int.signed_repr. auto.
  generalize Int.min_signed_neg; unfold Int.max_signed; omega.
Qed.

Theorem divs_mul_shift_2:
  forall x y m p,
  divs_mul_params (Int.signed y) = Some(p, m) ->
  m >= Int.half_modulus ->
  0 <= p < 32 /\
  Int.divs x y = Int.add (Int.shr (Int.add (Int.mulhs x (Int.repr m)) x) (Int.repr p))
                         (Int.shru x (Int.repr 31)).
Proof.
  intros. exploit divs_mul_shift_gen; eauto. instantiate (1 := x).
  intros (A & B & C). split. auto. rewrite C. f_equal. f_equal.
  rewrite Int.add_signed. unfold Int.mulhs. set (n := Int.signed x).
  transitivity (Int.repr (n * (m - Int.modulus) / Int.modulus + n)).
  f_equal.
  replace (n * (m - Int.modulus)) with (n * m +  (-n) * Int.modulus) by ring.
  rewrite Z_div_plus. ring. apply Int.modulus_pos.
  apply Int.eqm_samerepr. apply Int.eqm_add; auto with ints.
  apply Int.eqm_sym. eapply Int.eqm_trans. apply Int.eqm_signed_unsigned.
  apply Int.eqm_unsigned_repr_l. apply Int.eqm_refl2. f_equal. f_equal.
  rewrite Int.signed_repr_eq. rewrite Zmod_small by assumption.
  apply zlt_false. omega.
Qed.

Theorem divu_mul_shift:
  forall x y m p,
  divu_mul_params (Int.unsigned y) = Some(p, m) ->
  0 <= p < 32 /\
  Int.divu x y = Int.shru (Int.mulhu x (Int.repr m)) (Int.repr p).
Proof.
  intros. exploit divu_mul_params_sound; eauto. intros (A & B & C).
  split. auto.
  rewrite Int.shru_div_two_p. rewrite Int.unsigned_repr.
  unfold Int.divu, Int.mulhu. f_equal. rewrite C by apply Int.unsigned_range.
  rewrite two_p_is_exp by omega. rewrite <- Zdiv_Zdiv by (apply two_p_gt_ZERO; omega).
  f_equal. rewrite (Int.unsigned_repr m).
  rewrite Int.unsigned_repr. f_equal. ring.
  cut (0 <= Int.unsigned x * m / Int.modulus < Int.modulus).
  unfold Int.max_unsigned; omega.
  apply Zdiv_interval_1. omega. compute; auto. compute; auto.
  split. simpl. apply Z.mul_nonneg_nonneg. generalize (Int.unsigned_range x); omega. omega.
  apply Zle_lt_trans with (Int.modulus * m).
  apply Zmult_le_compat_r. generalize (Int.unsigned_range x); omega. omega.
  apply Zmult_lt_compat_l. compute; auto. omega.
  unfold Int.max_unsigned; omega.
  assert (32 < Int.max_unsigned) by (compute; auto). omega.
Qed.

(** Same, for 64-bit integers *)

Lemma divls_mul_params_sound:
  forall d m p,
  divls_mul_params d = Some(p, m) ->
  0 <= m < Int64.modulus /\ 0 <= p < 64 /\
  forall n,
  Int64.min_signed <= n <= Int64.max_signed ->
  Z.quot n d = Zdiv (m * n) (two_p (64 + p)) + (if zlt n 0 then 1 else 0).
Proof with (try discriminate).
  unfold divls_mul_params; intros d m' p'.
  destruct (find_div_mul_params Int64.wordsize
               (Int64.half_modulus - Int64.half_modulus mod d - 1) d 64)
  as [[p m] | ]...
  generalize (p - 64). intro p1.
  destruct (zlt 0 d)...
  destruct (zlt (two_p (64 + p1)) (m * d))...
  destruct (zle (m * d) (two_p (64 + p1) + two_p (p1 + 1)))...
  destruct (zle 0 m)...
  destruct (zlt m Int64.modulus)...
  destruct (zle 0 p1)...
  destruct (zlt p1 64)...
  intros EQ; inv EQ.
  split. auto. split. auto. intros.
  replace (64 + p') with (63 + (p' + 1)) by omega.
  apply Zquot_mul; try omega.
  replace (63 + (p' + 1)) with (64 + p') by omega. omega.
  change (Int64.min_signed <= n < Int64.half_modulus).
  unfold Int64.max_signed in H. omega.
Qed.

Lemma divlu_mul_params_sound:
  forall d m p,
  divlu_mul_params d = Some(p, m) ->
  0 <= m < Int64.modulus /\ 0 <= p < 64 /\
  forall n,
  0 <= n < Int64.modulus ->
  Zdiv n d = Zdiv (m * n) (two_p (64 + p)).
Proof with (try discriminate).
  unfold divlu_mul_params; intros d m' p'.
  destruct (find_div_mul_params Int64.wordsize
               (Int64.modulus - Int64.modulus mod d - 1) d 64)
  as [[p m] | ]...
  generalize (p - 64); intro p1.
  destruct (zlt 0 d)...
  destruct (zle (two_p (64 + p1)) (m * d))...
  destruct (zle (m * d) (two_p (64 + p1) + two_p p1))...
  destruct (zle 0 m)...
  destruct (zlt m Int64.modulus)...
  destruct (zle 0 p1)...
  destruct (zlt p1 64)...
  intros EQ; inv EQ.
  split. auto. split. auto. intros.
  apply Zdiv_mul_pos; try omega. assumption.
Qed.

Remark int64_shr'_div_two_p:
  forall x y, Int64.shr' x y = Int64.repr (Int64.signed x / two_p (Int.unsigned y)).
Proof.
  intros; unfold Int64.shr'. rewrite Int64.Zshiftr_div_two_p; auto. generalize (Int.unsigned_range y); omega.
Qed.

Lemma divls_mul_shift_gen:
  forall x y m p,
  divls_mul_params (Int64.signed y) = Some(p, m) ->
  0 <= m < Int64.modulus /\ 0 <= p < 64 /\
  Int64.divs x y = Int64.add (Int64.shr' (Int64.repr ((Int64.signed x * m) / Int64.modulus)) (Int.repr p))
                             (Int64.shru x (Int64.repr 63)).
Proof.
  intros. set (n := Int64.signed x). set (d := Int64.signed y) in *.
  exploit divls_mul_params_sound; eauto. intros (A & B & C).
  split. auto. split. auto.
  unfold Int64.divs. fold n; fold d. rewrite C by (apply Int64.signed_range).
  rewrite two_p_is_exp by omega. rewrite <- Zdiv_Zdiv.
  rewrite Int64.shru_lt_zero. unfold Int64.add. apply Int64.eqm_samerepr. apply Int64.eqm_add.
  rewrite int64_shr'_div_two_p. apply Int64.eqm_unsigned_repr_r. apply Int64.eqm_refl2.
  rewrite Int.unsigned_repr. f_equal.
  rewrite Int64.signed_repr. rewrite Int64.modulus_power. f_equal. ring.
  cut (Int64.min_signed <= n * m / Int64.modulus < Int64.half_modulus).
  unfold Int64.max_signed; omega.
  apply Zdiv_interval_1. generalize Int64.min_signed_neg; omega. apply Int64.half_modulus_pos.
  apply Int64.modulus_pos.
  split. apply Zle_trans with (Int64.min_signed * m). apply Zmult_le_compat_l_neg. omega. generalize Int64.min_signed_neg; omega.
  apply Zmult_le_compat_r. unfold n; generalize (Int64.signed_range x); tauto. tauto.
  apply Zle_lt_trans with (Int64.half_modulus * m).
  apply Zmult_le_compat_r. generalize (Int64.signed_range x); unfold n, Int64.max_signed; omega. tauto.
  apply Zmult_lt_compat_l. generalize Int64.half_modulus_pos; omega. tauto.
  assert (64 < Int.max_unsigned) by (compute; auto). omega.
  unfold Int64.lt; fold n. rewrite Int64.signed_zero. destruct (zlt n 0); apply Int64.eqm_unsigned_repr.
  apply two_p_gt_ZERO. omega.
  apply two_p_gt_ZERO. omega.
Qed.

Theorem divls_mul_shift_1:
  forall x y m p,
  divls_mul_params (Int64.signed y) = Some(p, m) ->
  m < Int64.half_modulus ->
  0 <= p < 64 /\
  Int64.divs x y = Int64.add (Int64.shr' (Int64.mulhs x (Int64.repr m)) (Int.repr p))
                             (Int64.shru' x (Int.repr 63)).
Proof.
  intros. exploit divls_mul_shift_gen; eauto. instantiate (1 := x).
  intros (A & B & C). split. auto. rewrite C.
  unfold Int64.mulhs. rewrite Int64.signed_repr. auto.
  generalize Int64.min_signed_neg; unfold Int64.max_signed; omega.
Qed.

Theorem divls_mul_shift_2:
  forall x y m p,
  divls_mul_params (Int64.signed y) = Some(p, m) ->
  m >= Int64.half_modulus ->
  0 <= p < 64 /\
  Int64.divs x y = Int64.add (Int64.shr' (Int64.add (Int64.mulhs x (Int64.repr m)) x) (Int.repr p))
                             (Int64.shru' x (Int.repr 63)).
Proof.
  intros. exploit divls_mul_shift_gen; eauto. instantiate (1 := x).
  intros (A & B & C). split. auto. rewrite C. f_equal. f_equal.
  rewrite Int64.add_signed. unfold Int64.mulhs. set (n := Int64.signed x).
  transitivity (Int64.repr (n * (m - Int64.modulus) / Int64.modulus + n)).
  f_equal.
  replace (n * (m - Int64.modulus)) with (n * m +  (-n) * Int64.modulus) by ring.
  rewrite Z_div_plus. ring. apply Int64.modulus_pos.
  apply Int64.eqm_samerepr. apply Int64.eqm_add; auto with ints.
  apply Int64.eqm_sym. eapply Int64.eqm_trans. apply Int64.eqm_signed_unsigned.
  apply Int64.eqm_unsigned_repr_l. apply Int64.eqm_refl2. f_equal. f_equal.
  rewrite Int64.signed_repr_eq. rewrite Zmod_small by assumption.
  apply zlt_false. omega.
Qed.

Remark int64_shru'_div_two_p:
  forall x y, Int64.shru' x y = Int64.repr (Int64.unsigned x / two_p (Int.unsigned y)).
Proof.
  intros; unfold Int64.shru'. rewrite Int64.Zshiftr_div_two_p; auto. generalize (Int.unsigned_range y); omega.
Qed.

Theorem divlu_mul_shift:
  forall x y m p,
  divlu_mul_params (Int64.unsigned y) = Some(p, m) ->
  0 <= p < 64 /\
  Int64.divu x y = Int64.shru' (Int64.mulhu x (Int64.repr m)) (Int.repr p).
Proof.
  intros. exploit divlu_mul_params_sound; eauto. intros (A & B & C).
  split. auto.
  rewrite int64_shru'_div_two_p. rewrite Int.unsigned_repr.
  unfold Int64.divu, Int64.mulhu. f_equal. rewrite C by apply Int64.unsigned_range.
  rewrite two_p_is_exp by omega. rewrite <- Zdiv_Zdiv by (apply two_p_gt_ZERO; omega).
  f_equal. rewrite (Int64.unsigned_repr m).
  rewrite Int64.unsigned_repr. f_equal. ring.
  cut (0 <= Int64.unsigned x * m / Int64.modulus < Int64.modulus).
  unfold Int64.max_unsigned; omega.
  apply Zdiv_interval_1. omega. compute; auto. compute; auto.
  split. simpl. apply Z.mul_nonneg_nonneg. generalize (Int64.unsigned_range x); omega. omega.
  apply Zle_lt_trans with (Int64.modulus * m).
  apply Zmult_le_compat_r. generalize (Int64.unsigned_range x); omega. omega.
  apply Zmult_lt_compat_l. compute; auto. omega.
  unfold Int64.max_unsigned; omega.
  assert (64 < Int.max_unsigned) by (compute; auto). omega.
Qed.

(** * Correctness of the smart constructors for division and modulus *)

Section CMCONSTRS.
Context mem `{external_calls: ExternalCalls mem} `{!I64HelpersCorrect mem}.

Variable prog: program.
Variable hf: helper_functions.
Hypothesis HELPERS: helper_functions_declared prog hf.
Let ge := Genv.globalenv prog.
Variable sp: val.
Variable e: env.
Variable m: mem.

Lemma is_intconst_sound:
  forall v a n le,
  is_intconst a = Some n -> eval_expr ge sp e m le a v -> v = Vint n.
Proof with (try discriminate).
  intros. unfold is_intconst in *.
  destruct a... destruct o... inv H. inv H0. destruct vl; inv H5. auto.
Qed.

Lemma eval_divu_mul:
  forall le x y p M,
  divu_mul_params (Int.unsigned y) = Some(p, M) ->
  nth_error le O = Some (Vint x) ->
  eval_expr ge sp e m le (divu_mul p M) (Vint (Int.divu x y)).
Proof.
  intros. unfold divu_mul. exploit (divu_mul_shift x); eauto. intros [A B].
  assert (C: eval_expr ge sp e m le (Eletvar 0) (Vint x)) by (apply eval_Eletvar; eauto).
  assert (D: eval_expr ge sp e m le (Eop (Ointconst (Int.repr M)) Enil) (Vint (Int.repr M))) by EvalOp.
  exploit eval_mulhu. eexact C. eexact D. intros (v & E & F). simpl in F. inv F.
  exploit eval_shruimm. eexact E. instantiate (1 := Int.repr p).
  intros [v [P Q]]. simpl in Q.
  replace (Int.ltu (Int.repr p) Int.iwordsize) with true in Q.
  inv Q. rewrite B. auto.
  unfold Int.ltu. rewrite Int.unsigned_repr. rewrite zlt_true; auto. tauto.
  assert (32 < Int.max_unsigned) by (compute; auto). omega.
Qed.

Theorem eval_divuimm:
  forall le e1 x n2 z,
  eval_expr ge sp e m le e1 x ->
  Val.divu x (Vint n2) = Some z ->
  exists v, eval_expr ge sp e m le (divuimm e1 n2) v /\ Val.lessdef z v.
Proof.
  unfold divuimm; intros. generalize H0; intros DIV.
  destruct x; simpl in DIV; try discriminate.
  destruct (Int.eq n2 Int.zero) eqn:Z2; inv DIV.
  destruct (Int.is_power2 n2) as [l | ] eqn:P2.
- erewrite Int.divu_pow2 by eauto.
  replace (Vint (Int.shru i l)) with (Val.shru (Vint i) (Vint l)).
  apply eval_shruimm; auto.
  simpl. erewrite Int.is_power2_range; eauto.
- destruct (Compopts.optim_for_size tt).
  + eapply eval_divu_base; eauto. EvalOp.
  + destruct (divu_mul_params (Int.unsigned n2)) as [[p M] | ] eqn:PARAMS.
    * exists (Vint (Int.divu i n2)); split; auto.
      econstructor; eauto. eapply eval_divu_mul; eauto.
    * eapply eval_divu_base; eauto. EvalOp.
Qed.

Theorem eval_divu:
  forall le a b x y z,
  eval_expr ge sp e m le a x ->
  eval_expr ge sp e m le b y ->
  Val.divu x y = Some z ->
  exists v, eval_expr ge sp e m le (divu a b) v /\ Val.lessdef z v.
Proof.
  unfold divu; intros.
  destruct (is_intconst b) as [n2|] eqn:B.
- exploit is_intconst_sound; eauto. intros EB; clear B.
  destruct (is_intconst a) as [n1|] eqn:A.
+ exploit is_intconst_sound; eauto. intros EA; clear A.
  destruct (Int.eq n2 Int.zero) eqn:Z. eapply eval_divu_base; eauto.
  subst. simpl in H1. rewrite Z in H1; inv H1.
  TrivialExists.
+ subst. eapply eval_divuimm; eauto.
- eapply eval_divu_base; eauto.
Qed.

Lemma eval_mod_from_div:
  forall le a n x y,
  eval_expr ge sp e m le a (Vint y) ->
  nth_error le O = Some (Vint x) ->
  eval_expr ge sp e m le (mod_from_div a n) (Vint (Int.sub x (Int.mul y n))).
Proof.
  unfold mod_from_div; intros.
  exploit eval_mulimm; eauto. instantiate (1 := n). intros [v [A B]].
  simpl in B. inv B. EvalOp.
Qed.

Theorem eval_moduimm:
  forall le e1 x n2 z,
  eval_expr ge sp e m le e1 x ->
  Val.modu x (Vint n2) = Some z ->
  exists v, eval_expr ge sp e m le (moduimm e1 n2) v /\ Val.lessdef z v.
Proof.
  unfold moduimm; intros. generalize H0; intros MOD.
  destruct x; simpl in MOD; try discriminate.
  destruct (Int.eq n2 Int.zero) eqn:Z2; inv MOD.
  destruct (Int.is_power2 n2) as [l | ] eqn:P2.
- erewrite Int.modu_and by eauto.
  change (Vint (Int.and i (Int.sub n2 Int.one)))
    with (Val.and (Vint i) (Vint (Int.sub n2 Int.one))).
  apply eval_andimm. auto.
- destruct (Compopts.optim_for_size tt).
  + eapply eval_modu_base; eauto. EvalOp.
  + destruct (divu_mul_params (Int.unsigned n2)) as [[p M] | ] eqn:PARAMS.
    * econstructor; split.
      econstructor; eauto. eapply eval_mod_from_div.
      eapply eval_divu_mul; eauto. simpl; eauto. simpl; eauto.
      rewrite Int.modu_divu. auto.
      red; intros; subst n2; discriminate.
    * eapply eval_modu_base; eauto. EvalOp.
Qed.

Theorem eval_modu:
  forall le a b x y z,
  eval_expr ge sp e m le a x ->
  eval_expr ge sp e m le b y ->
  Val.modu x y = Some z ->
  exists v, eval_expr ge sp e m le (modu a b) v /\ Val.lessdef z v.
Proof.
  unfold modu; intros.
  destruct (is_intconst b) as [n2|] eqn:B.
- exploit is_intconst_sound; eauto. intros EB; clear B.
  destruct (is_intconst a) as [n1|] eqn:A.
+ exploit is_intconst_sound; eauto. intros EA; clear A.
  destruct (Int.eq n2 Int.zero) eqn:Z. eapply eval_modu_base; eauto.
  subst. simpl in H1. rewrite Z in H1; inv H1.
  TrivialExists.
+ subst. eapply eval_moduimm; eauto.
- eapply eval_modu_base; eauto.
Qed.

Lemma eval_divs_mul:
  forall le x y p M,
  divs_mul_params (Int.signed y) = Some(p, M) ->
  nth_error le O = Some (Vint x) ->
  eval_expr ge sp e m le (divs_mul p M) (Vint (Int.divs x y)).
Proof.
  intros. unfold divs_mul.
  assert (C: eval_expr ge sp e m le (Eletvar 0) (Vint x)) by (apply eval_Eletvar; eauto).
  assert (D: eval_expr ge sp e m le (Eop (Ointconst (Int.repr M)) Enil) (Vint (Int.repr M))) by EvalOp.
  exploit eval_mulhs. eexact C. eexact D. intros (v & X & F). simpl in F; inv F.
  exploit eval_shruimm. eexact C. instantiate (1 := Int.repr (Int.zwordsize - 1)).
  intros [v1 [Y LD]]. simpl in LD.
  change (Int.ltu (Int.repr 31) Int.iwordsize) with true in LD.
  simpl in LD. inv LD.
  assert (RANGE: 0 <= p < 32 -> Int.ltu (Int.repr p) Int.iwordsize = true).
  { intros. unfold Int.ltu. rewrite Int.unsigned_repr. rewrite zlt_true by tauto. auto.
    assert (32 < Int.max_unsigned) by (compute; auto). omega. }
  destruct (zlt M Int.half_modulus).
- exploit (divs_mul_shift_1 x); eauto. intros [A B].
  exploit eval_shrimm. eexact X. instantiate (1 := Int.repr p). intros [v1 [Z LD]].
  simpl in LD. rewrite RANGE in LD by auto. inv LD.
  exploit eval_add. eexact Z. eexact Y. intros [v1 [W LD]].
  simpl in LD. inv LD.
  rewrite B. exact W.
- exploit (divs_mul_shift_2 x); eauto. intros [A B].
  exploit eval_add. eexact X. eexact C. intros [v1 [Z LD]].
  simpl in LD. inv LD.
  exploit eval_shrimm. eexact Z. instantiate (1 := Int.repr p). intros [v1 [U LD]].
  simpl in LD. rewrite RANGE in LD by auto. inv LD.
  exploit eval_add. eexact U. eexact Y. intros [v1 [W LD]].
  simpl in LD. inv LD.
  rewrite B. exact W.
Qed.

Theorem eval_divsimm:
  forall le e1 x n2 z,
  eval_expr ge sp e m le e1 x ->
  Val.divs x (Vint n2) = Some z ->
  exists v, eval_expr ge sp e m le (divsimm e1 n2) v /\ Val.lessdef z v.
Proof.
  unfold divsimm; intros. generalize H0; intros DIV.
  destruct x; simpl in DIV; try discriminate.
  destruct (Int.eq n2 Int.zero
            || Int.eq i (Int.repr Int.min_signed) && Int.eq n2 Int.mone) eqn:Z2; inv DIV.
  destruct (Int.is_power2 n2) as [l | ] eqn:P2.
- destruct (Int.ltu l (Int.repr 31)) eqn:LT31.
  + eapply eval_shrximm; eauto. eapply Val.divs_pow2; eauto.
  + eapply eval_divs_base; eauto. EvalOp.
- destruct (Compopts.optim_for_size tt).
  + eapply eval_divs_base; eauto. EvalOp.
  + destruct (divs_mul_params (Int.signed n2)) as [[p M] | ] eqn:PARAMS.
    * exists (Vint (Int.divs i n2)); split; auto.
      econstructor; eauto. eapply eval_divs_mul; eauto.
    * eapply eval_divs_base; eauto. EvalOp.
Qed.

Theorem eval_divs:
  forall le a b x y z,
  eval_expr ge sp e m le a x ->
  eval_expr ge sp e m le b y ->
  Val.divs x y = Some z ->
  exists v, eval_expr ge sp e m le (divs a b) v /\ Val.lessdef z v.
Proof.
  unfold divs; intros.
  destruct (is_intconst b) as [n2|] eqn:B.
- exploit is_intconst_sound; eauto. intros EB; clear B.
  destruct (is_intconst a) as [n1|] eqn:A.
+ exploit is_intconst_sound; eauto. intros EA; clear A.
  destruct (Int.eq n2 Int.zero) eqn:Z. eapply eval_divs_base; eauto.
  subst. simpl in H1.
  destruct (Int.eq n2 Int.zero || Int.eq n1 (Int.repr Int.min_signed) && Int.eq n2 Int.mone); inv H1.
  TrivialExists.
+ subst. eapply eval_divsimm; eauto.
- eapply eval_divs_base; eauto.
Qed.

Theorem eval_modsimm:
  forall le e1 x n2 z,
  eval_expr ge sp e m le e1 x ->
  Val.mods x (Vint n2) = Some z ->
  exists v, eval_expr ge sp e m le (modsimm e1 n2) v /\ Val.lessdef z v.
Proof.
  unfold modsimm; intros.
  exploit Val.mods_divs; eauto. intros [y [A B]].
  generalize A; intros DIV.
  destruct x; simpl in DIV; try discriminate.
  destruct (Int.eq n2 Int.zero
            || Int.eq i (Int.repr Int.min_signed) && Int.eq n2 Int.mone) eqn:Z2; inv DIV.
  destruct (Int.is_power2 n2) as [l | ] eqn:P2.
- destruct (Int.ltu l (Int.repr 31)) eqn:LT31.
  + exploit (eval_shrximm ge sp e m (Vint i :: le) (Eletvar O)).
    constructor. simpl; eauto. eapply Val.divs_pow2; eauto.
    intros [v1 [X LD]]. inv LD.
    econstructor; split. econstructor. eauto.
    apply eval_mod_from_div. eexact X. simpl; eauto.
    simpl. auto.
  + eapply eval_mods_base; eauto. EvalOp.
- destruct (Compopts.optim_for_size tt).
  + eapply eval_mods_base; eauto. EvalOp.
  + destruct (divs_mul_params (Int.signed n2)) as [[p M] | ] eqn:PARAMS.
    * econstructor; split.
      econstructor. eauto. apply eval_mod_from_div with (x := i); auto.
      eapply eval_divs_mul with (x := i); eauto.
      simpl. auto.
    * eapply eval_mods_base; eauto. EvalOp.
Qed.

Theorem eval_mods:
  forall le a b x y z,
  eval_expr ge sp e m le a x ->
  eval_expr ge sp e m le b y ->
  Val.mods x y = Some z ->
  exists v, eval_expr ge sp e m le (mods a b) v /\ Val.lessdef z v.
Proof.
  unfold mods; intros.
  destruct (is_intconst b) as [n2|] eqn:B.
- exploit is_intconst_sound; eauto. intros EB; clear B.
  destruct (is_intconst a) as [n1|] eqn:A.
+ exploit is_intconst_sound; eauto. intros EA; clear A.
  destruct (Int.eq n2 Int.zero) eqn:Z. eapply eval_mods_base; eauto.
  subst. simpl in H1.
  destruct (Int.eq n2 Int.zero || Int.eq n1 (Int.repr Int.min_signed) && Int.eq n2 Int.mone); inv H1.
  TrivialExists.
+ subst. eapply eval_modsimm; eauto.
- eapply eval_mods_base; eauto.
Qed.

Lemma eval_modl_from_divl:
  forall le a n x y,
  eval_expr ge sp e m le a (Vlong y) ->
  nth_error le O = Some (Vlong x) ->
  eval_expr ge sp e m le (modl_from_divl a n) (Vlong (Int64.sub x (Int64.mul y n))).
Proof.
  unfold modl_from_divl; intros.
  exploit eval_mullimm; eauto. eauto. instantiate (1 := n). intros (v1 & A1 & B1).
  assert (A0: eval_expr ge sp e m le (Eletvar O) (Vlong x)) by (constructor; auto).
  exploit eval_subl ; auto ; try apply HELPERS. exact A0. exact A1.
  intros (v2 & A2 & B2).
  simpl in B1; inv B1. simpl in B2; inv B2. exact A2.
Qed.

Lemma eval_divlu_mull:
  forall le x y p M,
  divlu_mul_params (Int64.unsigned y) = Some(p, M) ->
  nth_error le O = Some (Vlong x) ->
  eval_expr ge sp e m le (divlu_mull p M) (Vlong (Int64.divu x y)).
Proof.
  intros. unfold divlu_mull. exploit (divlu_mul_shift x); eauto. intros [A B].
  assert (A0: eval_expr ge sp e m le (Eletvar O) (Vlong x)) by (constructor; auto).
  exploit eval_mullhu. eauto. eexact A0. instantiate (1 := Int64.repr M). intros (v1 & A1 & B1).
  exploit eval_shrluimm. eauto. eexact A1. instantiate (1 := Int.repr p). intros (v2 & A2 & B2).
  simpl in B1; inv B1. simpl in B2. replace (Int.ltu (Int.repr p) Int64.iwordsize') with true in B2. inv B2.
  rewrite B. assumption.
  unfold Int.ltu. rewrite Int.unsigned_repr. rewrite zlt_true; auto. tauto.
  assert (64 < Int.max_unsigned) by (compute; auto). omega.
Qed.

Theorem eval_divlu:
  forall le a b x y z,
  eval_expr ge sp e m le a x ->
  eval_expr ge sp e m le b y ->
  Val.divlu x y = Some z ->
  exists v, eval_expr ge sp e m le (divlu a b) v /\ Val.lessdef z v.
Proof.
  unfold divlu; intros.
  destruct (is_longconst b) as [n2|] eqn:N2.
- assert (y = Vlong n2) by (eapply is_longconst_sound; eauto). subst y.
  destruct (is_longconst a) as [n1|] eqn:N1.
+ assert (x = Vlong n1) by (eapply is_longconst_sound; eauto). subst x.
  simpl in H1. destruct (Int64.eq n2 Int64.zero); inv H1.
  econstructor; split. apply eval_longconst. constructor.
+ destruct (Int64.is_power2' n2) as [l|] eqn:POW.
* exploit Val.divlu_pow2; eauto. intros EQ; subst z. apply eval_shrluimm; auto.
* destruct (Compopts.optim_for_size tt). eapply eval_divlu_base; eauto.
  destruct (divlu_mul_params (Int64.unsigned n2)) as [[p M]|] eqn:PARAMS.
** destruct x; simpl in H1; try discriminate.
   destruct (Int64.eq n2 Int64.zero); inv H1.
   econstructor; split; eauto. econstructor. eauto. eapply eval_divlu_mull; eauto.
** eapply eval_divlu_base; eauto.
- eapply eval_divlu_base; eauto.
Qed.

Theorem eval_modlu:
  forall le a b x y z,
  eval_expr ge sp e m le a x ->
  eval_expr ge sp e m le b y ->
  Val.modlu x y = Some z ->
  exists v, eval_expr ge sp e m le (modlu a b) v /\ Val.lessdef z v.
Proof.
  unfold modlu; intros.
  destruct (is_longconst b) as [n2|] eqn:N2.
- assert (y = Vlong n2) by (eapply is_longconst_sound; eauto). subst y.
  destruct (is_longconst a) as [n1|] eqn:N1.
+ assert (x = Vlong n1) by (eapply is_longconst_sound; eauto). subst x.
  simpl in H1. destruct (Int64.eq n2 Int64.zero); inv H1.
  econstructor; split. apply eval_longconst. constructor.
+ destruct (Int64.is_power2 n2) as [l|] eqn:POW.
* exploit Val.modlu_pow2; eauto. intros EQ; subst z. eapply eval_andl; eauto. apply eval_longconst.
* destruct (Compopts.optim_for_size tt). eapply eval_modlu_base; eauto.
  destruct (divlu_mul_params (Int64.unsigned n2)) as [[p M]|] eqn:PARAMS.
** destruct x; simpl in H1; try discriminate.
   destruct (Int64.eq n2 Int64.zero) eqn:Z; inv H1.
   rewrite Int64.modu_divu.
    econstructor; split; eauto. econstructor. eauto.
    eapply eval_modl_from_divl; eauto.
    eapply eval_divlu_mull; eauto.
    red; intros; subst n2; discriminate Z.
** eapply eval_modlu_base; eauto.
- eapply eval_modlu_base; eauto.
Qed.

Lemma eval_divls_mull:
  forall le x y p M,
  divls_mul_params (Int64.signed y) = Some(p, M) ->
  nth_error le O = Some (Vlong x) ->
  eval_expr ge sp e m le (divls_mull p M) (Vlong (Int64.divs x y)).
Proof.
  intros. unfold divls_mull.
  assert (A0: eval_expr ge sp e m le (Eletvar O) (Vlong x)).
  { constructor; auto. }
  exploit eval_mullhs. eauto. eexact A0. instantiate (1 := Int64.repr M).  intros (v1 & A1 & B1).
  exploit eval_addl; auto; try apply HELPERS. eexact A1. eexact A0. intros (v2 & A2 & B2).
  exploit eval_shrluimm. eauto. eexact A0. instantiate (1 := Int.repr 63). intros (v3 & A3 & B3).
  set (a4 := if zlt M Int64.half_modulus
             then mullhs (Eletvar 0) (Int64.repr M)
             else addl (mullhs (Eletvar 0) (Int64.repr M)) (Eletvar 0)).
  set (v4 := if zlt M Int64.half_modulus then v1 else v2).
  assert (A4: eval_expr ge sp e m le a4 v4).
  { unfold a4, v4; destruct (zlt M Int64.half_modulus); auto. }
  exploit eval_shrlimm. eauto. eexact A4. instantiate (1 := Int.repr p). intros (v5 & A5 & B5).
  exploit eval_addl; auto; try apply HELPERS. eexact A5. eexact A3. intros (v6 & A6 & B6).
  assert (RANGE: forall x, 0 <= x < 64 -> Int.ltu (Int.repr x) Int64.iwordsize' = true).
  { intros. unfold Int.ltu. rewrite Int.unsigned_repr. rewrite zlt_true by tauto. auto.
    assert (64 < Int.max_unsigned) by (compute; auto). omega. }
  simpl in B1; inv B1.
  simpl in B2; inv B2.
  simpl in B3; rewrite RANGE in B3 by omega; inv B3.
  destruct (zlt M Int64.half_modulus).
- exploit (divls_mul_shift_1 x); eauto. intros [A B].
  simpl in B5; rewrite RANGE in B5 by auto; inv B5.
  simpl in B6; inv B6.
  rewrite B; exact A6.
- exploit (divls_mul_shift_2 x); eauto. intros [A B].
  simpl in B5; rewrite RANGE in B5 by auto; inv B5.
  simpl in B6; inv B6.
  rewrite B; exact A6.
Qed.

Theorem eval_divls:
  forall le a b x y z,
  eval_expr ge sp e m le a x ->
  eval_expr ge sp e m le b y ->
  Val.divls x y = Some z ->
  exists v, eval_expr ge sp e m le (divls a b) v /\ Val.lessdef z v.
Proof.
  unfold divls; intros.
  destruct (is_longconst b) as [n2|] eqn:N2.
- assert (y = Vlong n2) by (eapply is_longconst_sound; eauto). subst y.
  destruct (is_longconst a) as [n1|] eqn:N1.
+ assert (x = Vlong n1) by (eapply is_longconst_sound; eauto). subst x.
  simpl in H1.
  destruct (Int64.eq n2 Int64.zero
         || Int64.eq n1 (Int64.repr Int64.min_signed) && Int64.eq n2 Int64.mone); inv H1.
  econstructor; split. apply eval_longconst. constructor.
+ destruct (Int64.is_power2' n2) as [l|] eqn:POW.
* destruct (Int.ltu l (Int.repr 63)) eqn:LT.
** exploit Val.divls_pow2; eauto. intros EQ. eapply eval_shrxlimm; eauto.
** eapply eval_divls_base; eauto.
* destruct (Compopts.optim_for_size tt). eapply eval_divls_base; eauto.
  destruct (divls_mul_params (Int64.signed n2)) as [[p M]|] eqn:PARAMS.
** destruct x; simpl in H1; try discriminate.
   destruct (Int64.eq n2 Int64.zero
             || Int64.eq i (Int64.repr Int64.min_signed) && Int64.eq n2 Int64.mone); inv H1.
   econstructor; split; eauto. econstructor. eauto.
   eapply eval_divls_mull; eauto.
** eapply eval_divls_base; eauto.
- eapply eval_divls_base; eauto.
Qed.

Theorem eval_modls:
  forall le a b x y z,
  eval_expr ge sp e m le a x ->
  eval_expr ge sp e m le b y ->
  Val.modls x y = Some z ->
  exists v, eval_expr ge sp e m le (modls a b) v /\ Val.lessdef z v.
Proof.
  unfold modls; intros.
  destruct (is_longconst b) as [n2|] eqn:N2.
- assert (y = Vlong n2) by (eapply is_longconst_sound; eauto). subst y.
  destruct (is_longconst a) as [n1|] eqn:N1.
+ assert (x = Vlong n1) by (eapply is_longconst_sound; eauto). subst x.
  simpl in H1.
  destruct (Int64.eq n2 Int64.zero
         || Int64.eq n1 (Int64.repr Int64.min_signed) && Int64.eq n2 Int64.mone); inv H1.
  econstructor; split. apply eval_longconst. constructor.
+ destruct (Int64.is_power2' n2) as [l|] eqn:POW.
* destruct (Int.ltu l (Int.repr 63)) eqn:LT.
**destruct x; simpl in H1; try discriminate.
  destruct (Int64.eq n2 Int64.zero
         || Int64.eq i (Int64.repr Int64.min_signed) && Int64.eq n2 Int64.mone) eqn:D; inv H1.
  assert (Val.divls (Vlong i) (Vlong n2) = Some (Vlong (Int64.divs i n2))).
  { simpl; rewrite D; auto. }
  exploit Val.divls_pow2; eauto. intros EQ.
  set (le' := Vlong i :: le).
  assert (A: eval_expr ge sp e m le' (Eletvar O) (Vlong i)) by (constructor; auto).
  exploit eval_shrxlimm; eauto. intros (v1 & A1 & B1). inv B1.
  econstructor; split.
  econstructor. eauto. eapply eval_modl_from_divl. eexact A1. reflexivity.
  rewrite Int64.mods_divs. auto.
**eapply eval_modls_base; eauto.
* destruct (Compopts.optim_for_size tt). eapply eval_modls_base; eauto.
  destruct (divls_mul_params (Int64.signed n2)) as [[p M]|] eqn:PARAMS.
** destruct x; simpl in H1; try discriminate.
   destruct (Int64.eq n2 Int64.zero
             || Int64.eq i (Int64.repr Int64.min_signed) && Int64.eq n2 Int64.mone); inv H1.
   econstructor; split; eauto. econstructor. eauto.
   rewrite Int64.mods_divs.
   eapply eval_modl_from_divl; auto.
   eapply eval_divls_mull; eauto.
** eapply eval_modls_base; eauto.
- eapply eval_modls_base; eauto.
Qed.

(** * Floating-point division *)

Theorem eval_divf:
  forall le a b x y,
  eval_expr ge sp e m le a x ->
  eval_expr ge sp e m le b y ->
  exists v, eval_expr ge sp e m le (divf a b) v /\ Val.lessdef (Val.divf x y) v.
Proof.
  intros until y. unfold divf. destruct (divf_match b); intros.
- unfold divfimm. destruct (Float.exact_inverse n2) as [n2' | ] eqn:EINV.
  + inv H0. inv H4. simpl in H6. inv H6. econstructor; split.
    EvalOp. constructor. eauto. constructor. EvalOp. simpl; eauto. constructor.
    simpl; eauto.
    destruct x; simpl; auto. erewrite Float.div_mul_inverse; eauto.
  + TrivialExists.
- TrivialExists.
Qed.

Theorem eval_divfs:
  forall le a b x y,
  eval_expr ge sp e m le a x ->
  eval_expr ge sp e m le b y ->
  exists v, eval_expr ge sp e m le (divfs a b) v /\ Val.lessdef (Val.divfs x y) v.
Proof.
  intros until y. unfold divfs. destruct (divfs_match b); intros.
- unfold divfsimm. destruct (Float32.exact_inverse n2) as [n2' | ] eqn:EINV.
  + inv H0. inv H4. simpl in H6. inv H6. econstructor; split.
    EvalOp. constructor. eauto. constructor. EvalOp. simpl; eauto. constructor.
    simpl; eauto.
    destruct x; simpl; auto. erewrite Float32.div_mul_inverse; eauto.
  + TrivialExists.
- TrivialExists.
Qed.

End CMCONSTRS.


Require Export B9_Inegalite_Triang.

Section METRIC_BASICS.

Definition LS0 := Distance Oo Oo.

Lemma NullDist : forall A,
	Distance A A = LS0.
Proof.
	intro; unfold LS0 in |- *; apply DistAA.
Qed.

Lemma NullLSlt : forall A B : Point,
	A <> B -> LSlt LS0 (Distance A B).
Proof.
	intros; rewrite <- (NullDist A).
	apply OrderLSlt; auto.
	canonize.
	elim (NotClockwiseAAB _ _ H0).
Qed.

Lemma EquiOrientedNotEquiOriented : forall A B C D : Point,
	A <> B ->
	EquiOriented A B C D ->
	~EquiOriented A B D C.
Proof.
	canonize.
	destruct (ClockwiseExists A B H) as (E, H2).
	elim (ClockwiseNotClockwise C D E); auto.
Qed.

Lemma LSltDistinct : forall A B C D,
	LSlt (Distance A B) (Distance C D) -> C <> D.
Proof.
	red in |- *; intros; subst.
	rewrite (DistAA D A) in H.
	destruct (LSltOrder A B A).
	 right; canonize.
	   elim (NotClockwiseAAB A x); auto.
	 trivial.
	 elim (EquiOrientedNotEquiOriented A B B A (sym_not_eq H1) H0).
	   canonize.
Qed.

Lemma LSltNull : forall A B,
	LSlt LS0 (Distance A B) -> A <> B.
Proof.
	red in |- *; intros; subst.
	rewrite <- (NullDist B) in H.
	destruct (LSltOrder B B B).
	 canonize.
	 trivial.
	 auto.
Qed.

Lemma NotLSltNullNull : ~LSlt LS0 LS0.
Proof.
	change (~ LSlt LS0 (Distance Oo Oo)) in |- *.
	intro.
	elim (LSltNull _ _ H).
	trivial.
Qed.

Lemma LS0NeutralRight : forall A B : Point,
	LSplus (Distance A B) LS0 = Distance A B.
Proof.
	intros.
	rewrite <- (NullDist B); rewrite Chasles; canonize.
	elim (NotClockwiseAAB B x); trivial.
Qed.

Lemma LS0NeutralLeft : forall A B : Point,
	LSplus LS0 (Distance A B) = Distance A B.
Proof.
	intros.
	rewrite <- (NullDist A); rewrite Chasles; canonize.
	elim (NotClockwiseAAB A x); trivial.
Qed.

Lemma EquiOrientedNotEquiOrientedABC : forall A B C : Point,
	A <> B ->
	EquiOriented A B B C ->
	~EquiOriented A C C B.
Proof.
	canonize.
	destruct (ClockwiseExists A B H) as (E, H2).
	decompose [or] (FourCases A B C).
	 elim (NotClockwiseBAA C B); auto.
	 elim (NotClockwiseBAA B C); apply H1; apply ClockwiseBCA; trivial.
	 canonize.
	   elim (ClockwiseNotClockwise B C E); auto.
	 generalizeChangeSense.
	   elim (ClockwiseNotClockwise B C E); auto.
Qed.

Lemma HalfLineAntisymLSlt  : forall A B C : Point,
	A <> B ->
	HalfLine A B C ->
	LSlt (Distance A B) (Distance A C) ->
	~LSlt (Distance A C) (Distance A B).
Proof.
	red in |- *; intros.
	assert (H3 : HalfLine A B C \/ HalfLine A C B).
	 intuition.
	 destruct (LSltOrder _ _ _ H3 H1).
	   elim (EquiOrientedNotEquiOrientedABC _ _ _ H H4).
	   assert (EquiOriented A C C B /\ C <> B).
	  apply LSltOrder.
	   generalizeChange.
	   trivial.
	  intuition.
Qed.

Lemma AntisymLSlt  : forall A B C : Point,
	A <> B ->
	LSlt (Distance A B) (Distance A C) ->
	~LSlt (Distance A C) (Distance A B).
Proof.
	intros.
	assert (H1 := LSltDistinct _ _ _ _ H0).
	destruct (ExistsHalfLineEquidistant A B A C H H1) as (D, (H2, H3)).
	rewrite <- H3; rewrite <- H3 in H0.
	apply HalfLineAntisymLSlt; auto.
Qed.

Lemma ClockwiseNotNullSide : forall A B C : Point,
	Clockwise A B C ->
	~Distance B C = LS0.
Proof.
	red in |- *; intros.
	assert (H1 := TriangularIneq _ _ _ H).
	rewrite H0 in H1; rewrite LS0NeutralRight in H1.
	elim (AntisymLSlt A C B).
	 apply sym_not_eq; apply (ClockwiseDistinctCA _ _ _ H).
	 trivial.
	 assert (H2 := TriangularIneq _ _ _ (ClockwiseBCA _ _ _ H)).
	   rewrite H0 in H2; rewrite LS0NeutralLeft in H2.
	   rewrite (DistSym A B); rewrite (DistSym A C); trivial.
Qed.

Lemma DistDistinctNull : forall A B D : Point,
	Distance A B = LS0 ->
	D <> A ->
	A = B.
Proof.
	intros.
	decompose [or] (FourCases D A B).
	 elim (ClockwiseNotNullSide _ _ _ H1); trivial.
	 elim (ClockwiseNotNullSide _ _ _ (ClockwiseBCA _ _ _ H2)); rewrite DistSym;
	  trivial.
	 decompose [or] (FourCases B A D).
	  elim (ClockwiseNotNullSide _ _ _ (ClockwiseCAB _ _ _ H2)); rewrite DistSym;
	   trivial.
	  elim (ClockwiseNotNullSide _ _ _ (ClockwiseCAB _ _ _ H3)); trivial.
	  apply (HalfLineEquidistantEqual D A B H0 H1).
	    rewrite <- (Chasles D A B H1 H2).
	    rewrite H; rewrite LS0NeutralRight; trivial.
	  assert (H3 : HalfLine D B A).
	   generalizeChange.
	   assert (H4 : D <> B).
	    canonize; subst.
	      destruct (ClockwiseExists B A H0) as (C, H4).
	      elim (NotClockwiseAAB B C); auto.
	    apply sym_eq; apply (HalfLineEquidistantEqual D B A H4 H3).
	      rewrite <- (Chasles D B A H3 H2).
	      rewrite (DistSym B A); rewrite H; rewrite LS0NeutralRight; trivial.
	 assert (H2 : A <> B).
	  intro; subst; canonize.
	    destruct (ClockwiseExists B D (sym_not_eq H0)) as (C, H2).
	    elim (NotClockwiseAAB B C); auto.
	  elim NotLSltNullNull.
	    pattern LS0 at 2 in |- *; rewrite <- H.
	    apply NullLSlt; trivial.
Qed.

Lemma DistNull : forall A B,
	Distance A B = LS0 -> A = B.
Proof.
	intros; destruct (Apart Oo Uu A DistinctOoUu).
	 apply (DistDistinctNull A B Oo); auto.
	 apply (DistDistinctNull A B Uu); auto.
Qed.

Lemma EquiDistantDistinct : forall A B C D : Point,
	A <> B ->
	Distance A B = Distance C D ->
	C <> D.
Proof.
	intuition; subst.
	elim H; apply DistNull.
	rewrite H0; apply NullDist.
Qed.

Lemma BetweenLSlt : forall A B C,
	(Between A B C) ->
	LSlt (Distance A B) (Distance A C).
Proof.
	intros.
	apply OrderLSlt; canonize.
	destruct (ClockwiseExists A B H1) as (D, H3).
	elim (ClockwiseDistinctAB B C D); auto.
Qed.

Lemma LSltBetween : forall A B C,
	A <> B ->
	HalfLine A B C ->
	LSlt (Distance A B) (Distance A C) ->
	(Between A B C).
Proof.
	intros.
	assert (H2 : EquiOriented A B B C /\ B <> C).
	 apply (LSltOrder A B C); intuition.
	 canonize.
Qed.

Lemma DistDistinct : forall A B,
	Distance A B <> LS0 -> A <> B.
Proof.
	intuition.
	subst; elim H; apply NullDist.
Qed.

Lemma DistinctDist : forall A B,
	A <> B -> Distance A B <> LS0.
Proof.
	intuition.
	elim H; apply DistNull; auto.
Qed.

End METRIC_BASICS.

Section METRIC_PROPERTIES.

Lemma ChaslesComm : forall A B C : Point,
	HalfLine A B C ->
	HalfLine C B A ->
	LSplus (Distance A B) (Distance B C) = LSplus (Distance B C) (Distance A B).
Proof.
	intros A B C H H0.
	rewrite (Chasles A B C H H0).
	rewrite (DistSym B C); rewrite (DistSym A B); rewrite (Chasles C B A H0 H).
	apply DistSym.
Qed.

Lemma ChaslesAssoc : forall A B C D : Point,
	HalfLine A B C ->
	HalfLine C B A ->
	HalfLine A B D ->
	HalfLine D B A ->
	HalfLine B C D ->
	HalfLine D C B ->
	HalfLine A C D ->
	HalfLine D C A ->
	LSplus (Distance A B) (LSplus (Distance B C) (Distance C D)) =
		LSplus (LSplus (Distance A B) (Distance B C)) (Distance C D).
Proof.
	intros.
	repeat (rewrite Chasles; auto).
Qed.

Lemma SSSEqualBD : forall A B C D : Point,
	Clockwise A B C ->
	Clockwise A D C ->
	Distance A B = Distance A D ->
	Distance B C = Distance D C ->
	B = D.
Proof.
	intros.
	assert (Hab := ClockwiseDistinctAB A B C H).
	assert (Hbc := ClockwiseDistinctBC A B C H).
	setCircle A A B Hab ipattern:(G1) ipattern:(Aab).
	setCircle C B C Hbc ipattern:(G2) ipattern:(Cbc).
	setCinterantiC G1 G2 Aab Cbc ipattern:(E) ipattern:(H3) ipattern:(H4) ipattern:(H5)
	 ipattern:(H6).
	 rewrite (DistSym A C); apply ClockwiseTriangleSpec; apply ClockwiseCAB; auto.
	 rewrite <- (H6 B).
	  apply H6.
	    intuition.
	   rewrite (DistSym C D); auto.
	   apply ClockwiseCAB; auto.
	  intuition.
	   rewrite (DistSym C B); auto.
	   apply ClockwiseCAB; auto.
Qed.

Lemma SSSEqualCD : forall A B C D : Point,
	Clockwise A B C ->
	Clockwise A B D ->
	Distance A C = Distance A D ->
	Distance B C = Distance B D ->
	C = D.
Proof.
	intros.
	assert (Hac := sym_not_eq (ClockwiseDistinctCA A B C H)).
	assert (Hbc := ClockwiseDistinctBC A B C H).
	setCircle A A C Hac ipattern:(G1) ipattern:(Aac).
	setCircle B B C Hbc ipattern:(G2) ipattern:(Bbc).
	setCinterantiC G2 G1 Bbc Aac ipattern:(E) ipattern:(H3) ipattern:(H4) ipattern:(H5)
	 ipattern:(H6).
	 rewrite (DistSym B A); rewrite (DistSym A C); apply ClockwiseTriangleSpec;
	  auto.
	 rewrite <- (H6 C).
	  apply H6.
	    intuition.
	  intuition.
Qed.

End METRIC_PROPERTIES.


From Hammer Require Import Hammer.

From compcert Require Import Coqlib.
Require Import Zwf.
Require Coq.Program.Wf.
Require Import Recdef.

Definition interv : Type := (Z * Z)%type.

Definition In (x: Z) (i: interv) : Prop := fst i <= x < snd i.

Lemma In_dec:
forall x i, {In x i} + {~In x i}.
Proof. hammer_hook "Intv" "Intv.In_dec".
unfold In; intros.
case (zle (fst i) x); intros.
case (zlt x (snd i)); intros.
left; auto.
right; intuition.
right; intuition.
Qed.

Lemma notin_range:
forall x i,
x < fst i \/ x >= snd i -> ~In x i.
Proof. hammer_hook "Intv" "Intv.notin_range".
unfold In; intros; omega.
Qed.

Lemma range_notin:
forall x i,
~In x i -> fst i < snd i -> x < fst i \/ x >= snd i.
Proof. hammer_hook "Intv" "Intv.range_notin".
unfold In; intros; omega.
Qed.

Definition empty (i: interv) : Prop := fst i >= snd i.

Lemma empty_dec:
forall i, {empty i} + {~empty i}.
Proof. hammer_hook "Intv" "Intv.empty_dec".
unfold empty; intros.
case (zle (snd i) (fst i)); intros.
left; omega.
right; omega.
Qed.

Lemma is_notempty:
forall i, fst i < snd i -> ~empty i.
Proof. hammer_hook "Intv" "Intv.is_notempty".
unfold empty; intros; omega.
Qed.

Lemma empty_notin:
forall x i, empty i -> ~In x i.
Proof. hammer_hook "Intv" "Intv.empty_notin".
unfold empty, In; intros. omega.
Qed.

Lemma in_notempty:
forall x i, In x i -> ~empty i.
Proof. hammer_hook "Intv" "Intv.in_notempty".
unfold empty, In; intros. omega.
Qed.

Definition disjoint (i j: interv) : Prop :=
forall x, In x i -> ~In x j.

Lemma disjoint_sym:
forall i j, disjoint i j -> disjoint j i.
Proof. hammer_hook "Intv" "Intv.disjoint_sym".
unfold disjoint; intros; red; intros. elim (H x); auto.
Qed.

Lemma empty_disjoint_r:
forall i j, empty j -> disjoint i j.
Proof. hammer_hook "Intv" "Intv.empty_disjoint_r".
unfold disjoint; intros. apply empty_notin; auto.
Qed.

Lemma empty_disjoint_l:
forall i j, empty i -> disjoint i j.
Proof. hammer_hook "Intv" "Intv.empty_disjoint_l".
intros. apply disjoint_sym. apply empty_disjoint_r; auto.
Qed.

Lemma disjoint_range:
forall i j,
snd i <= fst j \/ snd j <= fst i -> disjoint i j.
Proof. hammer_hook "Intv" "Intv.disjoint_range".
unfold disjoint, In; intros. omega.
Qed.

Lemma range_disjoint:
forall i j,
disjoint i j ->
empty i \/ empty j \/ snd i <= fst j \/ snd j <= fst i.
Proof. hammer_hook "Intv" "Intv.range_disjoint".
unfold disjoint, empty; intros.
destruct (zlt (fst i) (snd i)); auto.
destruct (zlt (fst j) (snd j)); auto.
right; right.
destruct (zlt (fst i) (fst j)).

destruct (zle (snd i) (fst j)).

auto.

elim (H (fst j)). red; omega. red; omega.

destruct (zle (snd j) (fst i)).

auto.

elim (H (fst i)). red; omega. red; omega.
Qed.

Lemma range_disjoint':
forall i j,
disjoint i j -> fst i < snd i -> fst j < snd j ->
snd i <= fst j \/ snd j <= fst i.
Proof. hammer_hook "Intv" "Intv.range_disjoint'".
intros. exploit range_disjoint; eauto. unfold empty; intuition omega.
Qed.

Lemma disjoint_dec:
forall i j, {disjoint i j} + {~disjoint i j}.
Proof. hammer_hook "Intv" "Intv.disjoint_dec".
intros.
destruct (empty_dec i). left; apply empty_disjoint_l; auto.
destruct (empty_dec j). left; apply empty_disjoint_r; auto.
destruct (zle (snd i) (fst j)). left; apply disjoint_range; auto.
destruct (zle (snd j) (fst i)). left; apply disjoint_range; auto.
right; red; intro. exploit range_disjoint; eauto. intuition.
Qed.

Definition shift (i: interv) (delta: Z) : interv := (fst i + delta, snd i + delta).

Lemma in_shift:
forall x i delta,
In x i -> In (x + delta) (shift i delta).
Proof. hammer_hook "Intv" "Intv.in_shift".
unfold shift, In; intros. simpl. omega.
Qed.

Lemma in_shift_inv:
forall x i delta,
In x (shift i delta) -> In (x - delta) i.
Proof. hammer_hook "Intv" "Intv.in_shift_inv".
unfold shift, In; simpl; intros. omega.
Qed.

Section ELEMENTS.

Variable lo: Z.

Function elements_rec (hi: Z) {wf (Zwf lo) hi} : list Z :=
if zlt lo hi then (hi-1) :: elements_rec (hi-1) else nil.
Proof.
intros. red. omega.
apply Zwf_well_founded.
Qed.

Lemma In_elements_rec:
forall hi x,
List.In x (elements_rec hi) <-> lo <= x < hi.
Proof. hammer_hook "Intv" "Intv.In_elements_rec".
intros. functional induction (elements_rec hi).
simpl; split; intros.
destruct H. clear IHl. omega. rewrite IHl in H. clear IHl. omega.
destruct (zeq (hi - 1) x); auto. right. rewrite IHl. clear IHl. omega.
simpl; intuition.
Qed.

End ELEMENTS.

Definition elements (i: interv) : list Z :=
elements_rec (fst i) (snd i).

Lemma in_elements:
forall x i,
In x i -> List.In x (elements i).
Proof. hammer_hook "Intv" "Intv.in_elements".
intros. unfold elements. rewrite In_elements_rec. auto.
Qed.

Lemma elements_in:
forall x i,
List.In x (elements i) -> In x i.
Proof. hammer_hook "Intv" "Intv.elements_in".
unfold elements; intros.
rewrite In_elements_rec in H. auto.
Qed.

Section FORALL.

Variables P Q: Z -> Prop.
Variable f: forall (x: Z), {P x} + {Q x}.
Variable lo: Z.

Program Fixpoint forall_rec (hi: Z) {wf (Zwf lo) hi}:
{forall x, lo <= x < hi -> P x}
+ {exists x, lo <= x < hi /\ Q x} :=
if zlt lo hi then
match f (hi - 1) with
| left _ =>
match forall_rec (hi - 1) with
| left _ => left _ _
| right _ => right _ _
end
| right _ => right _ _
end
else
left _ _
.
Next Obligation.
red. omega.
Qed.
Next Obligation.
assert (x = hi - 1 \/ x < hi - 1) by omega.
destruct H2. congruence. auto.
Qed.
Next Obligation.
exists wildcard'; split; auto. omega.
Qed.
Next Obligation.
exists (hi - 1); split; auto. omega.
Qed.
Next Obligation.
omegaContradiction.
Defined.

End FORALL.

Definition forall_dec
(P Q: Z -> Prop) (f: forall (x: Z), {P x} + {Q x}) (i: interv) :
{forall x, In x i -> P x} + {exists x, In x i /\ Q x} :=
forall_rec P Q f (fst i) (snd i).

Section FOLD.

Variable A: Type.
Variable f: Z -> A -> A.
Variable lo: Z.
Variable a: A.

Function fold_rec (hi: Z) {wf (Zwf lo) hi} : A :=
if zlt lo hi then f (hi - 1) (fold_rec (hi - 1)) else a.
Proof. hammer_hook "Intv" "Intv.forall_dec".
intros. red. omega.
apply Zwf_well_founded.
Qed.

Lemma fold_rec_elements:
forall hi, fold_rec hi = List.fold_right f a (elements_rec lo hi).
Proof. hammer_hook "Intv" "Intv.fold_rec_elements".
intros. functional induction (fold_rec hi).
rewrite elements_rec_equation. rewrite zlt_true; auto.
simpl. congruence.
rewrite elements_rec_equation. rewrite zlt_false; auto.
Qed.

End FOLD.

Definition fold {A: Type} (f: Z -> A -> A) (a: A) (i: interv) : A :=
fold_rec A f (fst i) a (snd i).

Lemma fold_elements:
forall (A: Type) (f: Z -> A -> A) a i,
fold f a i = List.fold_right f a (elements i).
Proof. hammer_hook "Intv" "Intv.fold_elements".
intros. unfold fold, elements. apply fold_rec_elements.
Qed.

Hint Resolve
notin_range range_notin
is_notempty empty_notin in_notempty
disjoint_sym empty_disjoint_r empty_disjoint_l
disjoint_range
in_shift in_shift_inv
in_elements elements_in : intv.


(* La librairie strandard est décrite ici

   https://coq.inria.fr/distrib/current/stdlib/

*)

Require Import List.  (* https://coq.inria.fr/distrib/current/stdlib/Coq.Lists.List.html *)
Require Import Arith. (* https://coq.inria.fr/distrib/current/stdlib/Coq.Arith.Arith_base.html *)

Load perm.

Section list_incl.

  Variable (X : Type).

  Implicit Types (l m : list X).

  Print In.
  Print incl.

  Fact incl_left_cons l m x : incl (x::m) l -> In x l /\ incl m l.
  Proof.
    intros H.
    split.
    apply H.
    left.
    reflexivity.
    intros ? ?.
    apply H.
    right.
    assumption.
  Qed.

  Fact incl_left_app l m k : incl (l++m) k <-> incl l k /\ incl m k.
  Proof.
    split. (* Divise en deux sous buts *)
    intro H.
    split. (* Divise en deux sous buts *)
    intros H2 H3.
    apply H. (* Permet de remplacer k par (l ++ m *)
    apply in_or_app.
    left.
    apply H3. (* Premier sous but résolu *)
    intros H4 H5.
    apply H. (*Permet de remplacer k par (l ++m) *)
    apply in_or_app.
    right. (* Permet d'appliquer H5 par la suite *)
    apply H5.
    intro H1.
    destruct H1. (* Dans le but de trouver une forme pour appliquer incl_app *)
    revert H0.
    revert H.
    apply incl_app.
  Qed.

  Fact incl_right_nil l : incl l nil -> l = nil.
  Proof.
    intros H.
    destruct l as [ | x l ].
    reflexivity. (* Pour enlever le premier sous but *)
    apply incl_left_cons in H.
    destruct H as (H1 & H2).
    destruct H1. (*Afin de résoudre la preuve *)
  Qed.

  Let incl_nil_x l : incl nil l.
  Proof.
    intros ? [].
  Qed.

  Fact incl_right_app l m p : incl m (l++p) -> exists m1 m2, m ~p m1++m2 /\ incl m1 l /\ incl m2 p.
  Proof.

    induction m as [ | x m IHm ].

    exists nil, nil; simpl; repeat split.
    apply perm_nil.
    apply incl_nil_x.
    apply incl_nil_x.

    intros H.
    apply incl_left_cons in H.
    destruct H as (H1 & H2).
    apply IHm in H2.
    destruct H2 as (m1 & m2 & H3 & H4 & H5).
    destruct IHm.

    apply perm_incl in H3.
    apply incl_appl with(m:=p) in H4.
    apply incl_appr with(m:=l) in H5.
    apply incl_app with(l:=m1) (m:=m2) (n:=l++p) in H4.
    apply incl_tran with(l:=m) in H4.
    apply H4.
    apply H3.
    apply H5.

    destruct H.
    destruct H.
    destruct H0.

    apply in_app_or in H1.
    destruct H1.

    exists (x::x0).
    exists (x1).
    split.
    apply perm_cons with(x:=x) in H.
    apply H.
    split.

  apply incl_cons with(a:=x) in H0.
    apply H0.
    apply H1.
    apply H2.

    exists (x0).
    exists (x::x1).
    split.
    apply perm_cons with(x:=x) in H.
    apply perm_trans with(l2:=(x::x0++x1)) (l3:= (x0++x::x1)) in H.
    apply H.
    apply perm_middle.
    split.
    apply H0.
    apply incl_cons with(a:=x) in H2.
    apply H2.
    apply H1.
Qed.

  Fact incl_right_cons_split x l m : incl m (x::l) -> exists m1 m2, m ~p m1 ++ m2 /\ (forall a, In a m1 -> a = x) /\ incl m2 l.
  Proof.
    intros H.
    apply (incl_right_app (x::nil) _ l) in H.
    destruct H.
    destruct H.
    destruct H.
    destruct H0.

    exists x0.
    exists x1.
    split.
    apply H.
    split.

    Focus 2.
    apply H1.

    intros.

    apply perm_incl in H.
    apply incl_cons with(l:=nil) in H2.
    apply incl_tran with(l:=a::nil) in H0.

    Focus 2.
    apply H2.

    Focus 2.
    apply incl_nil_x.

    apply incl_left_cons in H0.
    destruct H0.
    induction H0.
    subst.
    trivial.
    exfalso.
    apply H0.
Qed.

  Fact incl_right_cons_choose x l m : incl m (x::l) -> In x m \/ incl m l.
  Proof.
    intros H.
    apply incl_right_cons_split in H.
    destruct H as ( m1 & m2 & H1 & H2 & H3 ); simpl in H1.
    destruct m1 as [ | y m1 ].

    right.
    simpl in H1.
    apply perm_incl in H1.
    revert H1 H3.
    apply incl_tran.
    apply Forall_forall in H2.
    apply Forall_inv in H2.
    subst.
    apply perm_sym in H1.
    apply perm_incl in H1.
    apply incl_left_cons in H1.
    destruct H1.
    left.
    apply H.
Qed.

  Fact list_remove (x : X) l : In x l -> exists m, incl l (x::m) /\ length m < length l.
  Proof.
    induction l as [ | y l IHl ].
    intros [].
    intros [ ? | H ].

    subst.

    exists l.
    split.
    apply incl_refl.
    simpl; apply lt_n_Sn.

    specialize (IHl H).
    destruct IHl as (m & H1 & H2).
    exists (y::m); split.
    intros u [ Hu | Hu ].
    subst; right; left; auto.
    apply H1 in Hu.
    destruct Hu; [ left | right; right ]; auto.
    simpl; apply lt_n_S; auto.
  Qed.

End list_incl.


Require Export ProjectiveGeometry.Dev.fano_matroid_tactics.

(** Fano's plane **)
(** also known as Pg(2,2). **)

(** To show that our axiom system is consistent we build a finite model. **)

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

Section s_fanoPlaneModelRk.

Parameter A B C D E F G : Point.

Parameter is_only_7_pts : forall P, {P=A}+{P=B}+{P=C}+{P=D}+{P=E}+{P=F}+{P=G}.

Parameter rk_points : rk(A :: nil) = 1 /\ rk(B :: nil) = 1 /\ rk(C :: nil) = 1 /\ rk(D :: nil) = 1 /\
rk(E :: nil) = 1 /\ rk(F :: nil) = 1 /\ rk(G :: nil) = 1.

Parameter rk_distinct_points :
rk(A :: B :: nil) = 2 /\ rk(A :: C :: nil) = 2 /\ rk(A :: D :: nil) = 2 /\ rk(A :: E :: nil) = 2 /\rk(A :: F :: nil) = 2 /\ rk(A :: G :: nil) = 2 /\
rk(B :: C :: nil) = 2 /\ rk(B :: D :: nil) = 2 /\ rk(B :: E :: nil) = 2 /\ rk(B :: F :: nil) = 2 /\ rk(B :: G :: nil) = 2 /\
rk(C :: D :: nil) = 2 /\ rk(C :: E :: nil) = 2 /\ rk(C :: F :: nil) = 2 /\ rk(C :: G :: nil) = 2 /\
rk(D :: E :: nil) = 2 /\ rk(D :: F :: nil) = 2 /\ rk(D :: G :: nil) = 2 /\
rk(E :: F :: nil) = 2 /\ rk(E :: G :: nil) = 2 /\
rk(F :: G :: nil) = 2.

Parameter rk_lines : rk (A :: B :: F :: nil) = 2 /\ rk (B :: C :: D :: nil) = 2 /\
rk (C :: A :: E :: nil) = 2 /\ rk (A :: D :: G :: nil) = 2 /\ rk (B :: E :: G :: nil) = 2 /\
rk (C :: F :: G :: nil) = 2 /\ rk (D :: E :: F :: nil) = 2.

Parameter rk_planes :
rk(A :: B :: C :: nil) = 3 /\ rk(A :: B :: D :: nil) = 3 /\ rk(A :: B :: E :: nil) = 3 /\ rk(A :: B :: G :: nil) = 3 /\
rk(A :: C :: D :: nil) = 3 /\ rk(A :: C :: F :: nil) = 3 /\ rk(A :: C :: G :: nil) = 3 /\ rk(A :: D :: E :: nil) = 3 /\
rk(A :: D :: F :: nil) = 3 /\ rk(A :: E :: F :: nil) = 3 /\ rk(A :: E :: G :: nil) = 3 /\ rk(A :: F :: G :: nil) = 3 /\
rk(B :: C :: E :: nil) = 3 /\ rk(B :: C :: F :: nil) = 3 /\ rk(B :: C :: G :: nil) = 3 /\ rk(B :: D :: E :: nil) = 3 /\
rk(B :: D :: F :: nil) = 3 /\ rk(B :: D :: G :: nil) = 3 /\ rk(B :: E :: F :: nil) = 3 /\ rk(B :: F :: G :: nil) = 3 /\
rk(C :: D :: E :: nil) = 3 /\ rk(C :: D :: F :: nil) = 3 /\ rk(C :: D :: G :: nil) = 3 /\ rk(C :: E :: F :: nil) = 3 /\
rk(C :: E :: G :: nil) = 3 /\ rk(D :: E :: G :: nil) = 3 /\ rk(D :: F :: G :: nil) = 3 /\ rk(E :: F :: G :: nil) = 3.

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

Ltac case_clear P := let HA:= fresh in let HB:=fresh in let HC:=fresh in let HD:=fresh in let HE:=fresh in let HF:=fresh in let HG:=fresh in
destruct (is_only_7_pts P) as [[[[[[HA | HB] | HC] | HD] | HE ] | HF ] | HG]; subst P.

(** rk-singleton : The rank of a point is always greater than one  **)
Lemma rk_singleton_ge : forall P, rk (P :: nil) >= 1.
Proof.
intros.
assert(HH := rk_points);use HH.
case_clear P;intuition.
Qed.

Lemma rk_couple_ge_alt : forall P Q, rk(P :: Q :: nil) = 2 -> rk(P :: Q :: nil) >=2.
Proof.
intuition.
Qed.

(** rk-couple : The rank of a two distinct points is always greater than one  **)
Lemma rk_couple_ge : forall P Q, ~ P = Q -> rk(P :: Q :: nil) >= 2.
Proof.
intros.
assert(HH := rk_distinct_points);use HH.
apply rk_couple_ge_alt.
case_clear P;case_clear Q;try equal_degens;try assumption;rewrite couple_equal;assumption.
Qed.

Lemma triple_rk2_1 : forall P R, rk(P :: R :: nil) = 2 -> rk(P :: P :: R :: nil) = 2.
Proof.
intros.
assert(HH : equivlist (P :: P :: R :: nil) (P :: R :: nil));[my_inO|];rewrite HH;intuition.
Qed.

Lemma triple_rk2_2 : forall P R, rk(P :: R :: nil) = 2 -> rk(P :: R :: P :: nil) = 2.
Proof.
intros.
assert(HH : equivlist (P :: R :: P :: nil) (P :: R :: nil));[my_inO|];rewrite HH;intuition.
Qed.

Lemma triple_rk2_3 : forall P R, rk(P :: R :: nil) = 2 -> rk(R :: P :: P :: nil) = 2.
Proof.
intros.
assert(HH : equivlist (R :: P :: P :: nil) (P :: R :: nil));[my_inO|];rewrite HH;intuition.
Qed.

Ltac degens_rk2' :=
  solve[ first [apply triple_rk2_1 | apply triple_rk2_2 | apply triple_rk2_3];rk_couple_triple].

Ltac solve_ex_1 L := solve[exists L;repeat split;[try degens_rk2';assumption|rk_couple_triple|rk_couple_triple]].

Ltac solve_ex_p_1 := first [
        solve_ex_1 A
     |  solve_ex_1 B
     |  solve_ex_1 C
     |  solve_ex_1 D
     |  solve_ex_1 E
     |  solve_ex_1 F
     |  solve_ex_1 G
 ].

Ltac rk_three_points_simplify P Q :=
match goal with
| H : rk(P :: Q :: ?X :: nil) = 2 |- _ => solve_ex_1 X
| H : rk(P :: ?X :: Q :: nil) = 2 |- _ => rewrite <-triple_equal_1 in H;solve_ex_1 X
| H : rk(Q :: P :: ?X :: nil) = 2 |- _ => rewrite <-triple_equal_2 in H;solve_ex_1 X
| H : rk(Q :: ?X :: P :: nil) = 2 |- _ => rewrite <-triple_equal_3 in H;solve_ex_1 X
| H : rk(?X :: P :: Q :: nil) = 2 |- _ => rewrite <-triple_equal_4 in H;solve_ex_1 X
| H : rk(?X :: Q :: P :: nil) = 2 |- _ => rewrite <-triple_equal_5 in H;solve_ex_1 X
end.

Ltac rk_three_points_simplify_bis :=
match goal with
| H : _ |- exists R, rk (?P :: ?P :: _ :: nil) = 2 /\ _ /\ _ => solve_ex_p_1
| H : _ |- exists R, rk (?P :: ?Q :: _ :: nil) = 2 /\ _ /\ _ => rk_three_points_simplify P Q
end.

(** rk-three_point_on_lines : Each lines contains at least three points **)
Lemma rk_three_points_on_lines : forall P Q, exists R,
rk (P :: Q :: R :: nil) = 2 /\ rk (Q :: R :: nil) = 2 /\ rk (P :: R :: nil) = 2.
Proof.
intros.
assert(HH := rk_distinct_points);assert(HH0 := rk_lines);use HH;use HH0.
case_clear P;case_clear Q;rk_three_points_simplify_bis.
Qed.

Ltac solve_ex_2 L := solve [exists L;repeat split;try degens_rk2';rk_couple_triple].

Ltac solve_ex_p_2 := first [
        solve_ex_2 A
     |  solve_ex_2 B
     |  solve_ex_2 C
     |  solve_ex_2 D
     |  solve_ex_2 E
     |  solve_ex_2 F
     |  solve_ex_2 G
 ].

Ltac rk_inter_simplify X Y :=
match goal with
| H : _ |- exists J, rk (_ :: Y :: _ :: nil) = 2 /\ rk (_ :: _ :: _ :: nil) = 2 => try solve_ex_2 Y
| H : _ |- exists J, rk (Y :: _ :: _ :: nil) = 2 /\ rk (_ :: _ :: _ :: nil) = 2 => try solve_ex_2 Y
| H : _ |- exists J, rk (_ :: _ :: _ :: nil) = 2 /\ rk (_ :: X :: _ :: nil) = 2 => try solve_ex_2 X
| H : _ |- exists J, rk (_ :: _ :: _ :: nil) = 2 /\ rk (X :: _ :: _ :: nil) = 2 => try solve_ex_2 X
| H : _ |- exists J, rk (_ :: _ :: _ :: nil) = 2 /\ rk (_ :: _ :: _ :: nil) = 2 => try solve_ex_2 X
end.

Ltac rk_inter_simplify_bis P Q R S X :=
match goal with
| H : rk(R :: S :: ?Y :: nil) = 2 |- _ => rk_inter_simplify X Y
| H : rk(R :: ?Y :: S :: nil) = 2 |- _ => rk_inter_simplify X Y
| H : rk(S :: R :: ?Y :: nil) = 2 |- _ => rk_inter_simplify X Y
| H : rk(S :: ?Y :: R :: nil) = 2 |- _ => rk_inter_simplify X Y
| H : rk(?Y :: R :: S :: nil) = 2 |- _ => rk_inter_simplify X Y
| H : rk(?Y :: S :: R :: nil) = 2 |- _ => rk_inter_simplify X Y
end.

Ltac rk_inter_simplify_bis_bis :=
match goal with
| H : _ |- exists J, rk (?P :: ?P :: _ :: nil) = 2 /\ rk (?P :: ?P :: _ :: nil) = 2 => solve_ex_p_2
| H : _ |- exists J, rk (?P :: ?P :: _ :: nil) = 2 /\ rk (?Q :: ?Q :: _ :: nil) = 2 => solve_ex_p_2

| H : _ |- exists J, rk (?P :: ?Q :: _ :: nil) = 2 /\ rk (?P :: ?P :: _ :: nil) = 2 => solve_ex_2 P
| H : _ |- exists J, rk (?Q :: ?P :: _ :: nil) = 2 /\ rk (?Q :: ?Q :: _ :: nil) = 2 => solve_ex_2 P
| H : _ |- exists J, rk (?Q :: ?Q :: _ :: nil) = 2 /\ rk (?P :: ?Q :: _ :: nil) = 2 => solve_ex_2 P
| H : _ |- exists J, rk (?Q :: ?Q :: _ :: nil) = 2 /\ rk (?Q :: ?P :: _ :: nil) = 2 => solve_ex_2 P

| H : _ |- exists J, rk (?P :: ?Q :: _ :: nil) = 2 /\ rk (?R :: ?R :: _ :: nil) = 2 => solve_ex_2 P
| H : _ |- exists J, rk (?R :: ?R :: _ :: nil) = 2 /\ rk (?P :: ?Q :: _ :: nil) = 2 => solve_ex_2 P

| H : _ |- exists J, rk (?P :: ?Q :: _ :: nil) = 2 /\ rk (?R :: ?P :: _ :: nil) = 2 => solve_ex_2 P
| H : _ |- exists J, rk (?P :: ?Q :: _ :: nil) = 2 /\ rk (?P :: ?R :: _ :: nil) = 2 => solve_ex_2 P
| H : _ |- exists J, rk (?Q :: ?P :: _ :: nil) = 2 /\ rk (?R :: ?P :: _ :: nil) = 2 => solve_ex_2 P
| H : _ |- exists J, rk (?Q :: ?P :: _ :: nil) = 2 /\ rk (?P :: ?R :: _ :: nil) = 2 => solve_ex_2 P

| H : rk(?P :: ?Q :: ?X :: nil) = 2 |- exists J, rk (?P :: ?Q :: _ :: nil) = 2 /\ rk (?R :: ?S :: _ :: nil) = 2 => rk_inter_simplify_bis P Q R S X
| H : rk(?P :: ?X :: ?Q :: nil) = 2 |- exists J, rk (?P :: ?Q :: _ :: nil) = 2 /\ rk (?R :: ?S :: _ :: nil) = 2 => rk_inter_simplify_bis P Q R S X
| H : rk(?Q :: ?P :: ?X :: nil) = 2 |- exists J, rk (?P :: ?Q :: _ :: nil) = 2 /\ rk (?R :: ?S :: _ :: nil) = 2 => rk_inter_simplify_bis P Q R S X
| H : rk(?Q :: ?X :: ?P :: nil) = 2 |- exists J, rk (?P :: ?Q :: _ :: nil) = 2 /\ rk (?R :: ?S :: _ :: nil) = 2 => rk_inter_simplify_bis P Q R S X
| H : rk(?X :: ?P :: ?Q :: nil) = 2 |- exists J, rk (?P :: ?Q :: _ :: nil) = 2 /\ rk (?R :: ?S :: _ :: nil) = 2 => rk_inter_simplify_bis P Q R S X
| H : rk(?X :: ?Q :: ?P :: nil) = 2 |- exists J, rk (?P :: ?Q :: _ :: nil) = 2 /\ rk (?R :: ?S :: _ :: nil) = 2 => rk_inter_simplify_bis P Q R S X
end.

(** rk-inter : Two lines always intersect in the plane **)
Lemma rk_inter : forall P Q R S, exists J, rk (P :: Q :: J :: nil) = 2 /\ rk (R :: S :: J :: nil) = 2.
Proof.
intros.
assert(HH := rk_distinct_points);assert(HH0 := rk_lines);use HH;use HH0.
case_clear P;case_clear Q;
abstract(case_clear R;case_clear S;rk_inter_simplify_bis_bis).
Qed.

(** rk-lower_dim : There exist three points which are not collinear **)
Lemma rk_lower_dim : exists P0 P1 P2, rk( P0 :: P1 :: P2 :: nil) >=3.
Proof.
intros.
assert(HH := rk_planes);use HH.
exists A;exists B;exists C;intuition.
Qed.

End s_fanoPlaneModelRk.


Inductive Boole : Set :=
  | igaz : Boole
  | hamis : Boole.

Print Boole_ind.

Definition Boole_Or (b1:Boole) (b2:Boole) : Boole :=
  match b1 with
    | igaz => match b2 with
                | igaz => igaz
                | hamis => igaz
              end
    | hamis => match b2 with
                | igaz => igaz
                | hamis => hamis
              end
  end.

Notation "x 'vagy' y" := (Boole_Or x y) (at level 20) : type_scope.

Check igaz vagy hamis.

Eval compute in (igaz vagy hamis).

Definition Boole_And (b1 : Boole) (b2: Boole) : Boole :=
  match b1 with
    | igaz => match b2 with | igaz => igaz | hamis => hamis end
    | hamis => match b2 with | igaz => hamis | hamis => hamis end end.

Notation "x 'es' y" := (Boole_And x y) (at level 20) : type_scope.

Definition Boole_Not (b : Boole) : Boole :=
  match b with
    | igaz => hamis
    | hamis => igaz
  end.

Notation "'nem' x" := (Boole_Not x) (at level 20) : type_scope.

Theorem DM_2 : (forall x y : Boole, (nem x) es (nem y) = nem (x vagy y)).
Proof.
  intros.
  Print Boole_ind.
  apply Boole_ind with (P:=fun x => (nem x) es (nem y) = nem (x vagy y)).
  apply Boole_ind with (P:=fun y => (nem igaz) es (nem y) = nem (igaz vagy y)).
  unfold Boole_And.
  unfold Boole_Or.
  unfold Boole_Not.
  reflexivity.
  auto.
  apply Boole_ind with (P:=fun y=> (nem hamis) es (nem y) = nem (hamis vagy y)).
  unfold Boole_And.
  unfold Boole_Or.
  unfold Boole_Not.
  reflexivity.
  auto.
Qed.