(**
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/

Copyright (C) 2011-2013 Sylvie Boldo
#<br />#
Copyright (C) 2011-2013 Guillaume Melquiond

This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
COPYING file for more details.
*)

Require Import ZArith.
Require Import Fcore_Zaux.
Require Import ZOdiv.

(** Computes the number of bits (radix 2) of a positive integer.

It serves as an upper bound on the number of digits to ensure termination.
*)

Fixpoint digits2_Pnat (n : positive) : nat :=
  match n with
  | xH => O
  | xO p => S (digits2_Pnat p)
  | xI p => S (digits2_Pnat p)
  end.

Theorem digits2_Pnat_correct :
  forall n,
  let d := digits2_Pnat n in
  (Zpower_nat 2 d <= Zpos n < Zpower_nat 2 (S d))%Z.
Proof.
intros n d. unfold d. clear.
assert (Hp: forall m, (Zpower_nat 2 (S m) = 2 * Zpower_nat 2 m)%Z) by easy.
induction n ; simpl.
rewrite Zpos_xI, 2!Hp.
omega.
rewrite (Zpos_xO n), 2!Hp.
omega.
now split.
Qed.

Section Fcore_digits.

Variable beta : radix.

Definition Zdigit n k := ZOmod (ZOdiv n (Zpower beta k)) beta.

Theorem Zdigit_lt :
  forall n k,
  (k < 0)%Z ->
  Zdigit n k = Z0.
Proof.
intros n [|k|k] Hk ; try easy.
now case n.
Qed.

Theorem Zdigit_0 :
  forall k, Zdigit 0 k = Z0.
Proof.
intros k.
unfold Zdigit.
rewrite ZOdiv_0_l.
apply ZOmod_0_l.
Qed.

Theorem Zdigit_opp :
  forall n k,
  Zdigit (-n) k = Zopp (Zdigit n k).
Proof.
intros n k.
unfold Zdigit.
rewrite ZOdiv_opp_l.
apply ZOmod_opp_l.
Qed.

Theorem Zdigit_ge_Zpower_pos :
  forall e n,
  (0 <= n < Zpower beta e)%Z ->
  forall k, (e <= k)%Z -> Zdigit n k = Z0.
Proof.
intros e n Hn k Hk.
unfold Zdigit.
rewrite ZOdiv_small.
apply ZOmod_0_l.
split.
apply Hn.
apply Zlt_le_trans with (1 := proj2 Hn).
replace k with (e + (k - e))%Z by ring.
rewrite Zpower_plus.
rewrite <- (Zmult_1_r (beta ^ e)) at 1.
apply Zmult_le_compat_l.
apply (Zlt_le_succ 0).
apply Zpower_gt_0.
now apply Zle_minus_le_0.
apply Zlt_le_weak.
now apply Zle_lt_trans with n.
generalize (Zle_lt_trans _ _ _ (proj1 Hn) (proj2 Hn)).
clear.
now destruct e as [|e|e].
now apply Zle_minus_le_0.
Qed.

Theorem Zdigit_ge_Zpower :
  forall e n,
  (Zabs n < Zpower beta e)%Z ->
  forall k, (e <= k)%Z -> Zdigit n k = Z0.
Proof.
intros e [|n|n] Hn k.
easy.
apply Zdigit_ge_Zpower_pos.
now split.
intros He.
change (Zneg n) with (Zopp (Zpos n)).
rewrite Zdigit_opp.
rewrite Zdigit_ge_Zpower_pos with (2 := He).
apply Zopp_0.
now split.
Qed.

Theorem Zdigit_not_0_pos :
  forall e n, (0 <= e)%Z ->
  (Zpower beta e <= n < Zpower beta (e + 1))%Z ->
  Zdigit n e <> Z0.
Proof.
intros e n He (Hn1,Hn2).
unfold Zdigit.
rewrite <- ZOdiv_mod_mult.
rewrite ZOmod_small.
intros H.
apply Zle_not_lt with (1 := Hn1).
rewrite (ZO_div_mod_eq n (beta ^ e)).
rewrite H, Zmult_0_r, Zplus_0_l.
apply ZOmod_lt_pos_pos.
apply Zle_trans with (2 := Hn1).
apply Zpower_ge_0.
now apply Zpower_gt_0.
split.
apply Zle_trans with (2 := Hn1).
apply Zpower_ge_0.
replace (beta ^ e * beta)%Z with (beta ^ (e + 1))%Z.
exact Hn2.
rewrite <- (Zmult_1_r beta) at 3.
now apply (Zpower_plus beta e 1).
Qed.

Theorem Zdigit_not_0 :
  forall e n, (0 <= e)%Z ->
  (Zpower beta e <= Zabs n < Zpower beta (e + 1))%Z ->
  Zdigit n e <> Z0.
Proof.
intros e n He Hn.
destruct (Zle_or_lt 0 n) as [Hn'|Hn'].
rewrite (Zabs_eq _ Hn') in Hn.
now apply Zdigit_not_0_pos.
intros H.
rewrite (Zabs_non_eq n) in Hn by now apply Zlt_le_weak.
apply (Zdigit_not_0_pos _ _ He Hn).
now rewrite Zdigit_opp, H.
Qed.

Theorem Zdigit_mul_pow :
  forall n k k', (0 <= k')%Z ->
  Zdigit (n * Zpower beta k') k = Zdigit n (k - k').
Proof.
intros n k k' Hk'.
destruct (Zle_or_lt k' k) as [H|H].
revert k H.
pattern k' ; apply Zlt_0_ind with (2 := Hk').
clear k' Hk'.
intros k' IHk' Hk' k H.
unfold Zdigit.
apply (f_equal (fun x => ZOmod x beta)).
pattern k at 1 ; replace k with (k - k' + k')%Z by ring.
rewrite Zpower_plus with (2 := Hk').
apply ZOdiv_mult_cancel_r.
apply Zgt_not_eq.
now apply Zpower_gt_0.
now apply Zle_minus_le_0.
destruct (Zle_or_lt 0 k) as [H0|H0].
rewrite (Zdigit_lt n) by omega.
unfold Zdigit.
replace k' with (k' - k + k)%Z by ring.
rewrite Zpower_plus with (2 := H0).
rewrite Zmult_assoc, ZO_div_mult.
replace (k' - k)%Z with (k' - k - 1 + 1)%Z by ring.
rewrite Zpower_exp by omega.
rewrite Zmult_assoc.
change (Zpower beta 1) with (beta * 1)%Z.
rewrite Zmult_1_r.
apply ZO_mod_mult.
apply Zgt_not_eq.
now apply Zpower_gt_0.
apply Zle_minus_le_0.
now apply Zlt_le_weak.
rewrite Zdigit_lt with (1 := H0).
apply sym_eq.
apply Zdigit_lt.
omega.
Qed.

Theorem Zdigit_div_pow :
  forall n k k', (0 <= k)%Z -> (0 <= k')%Z ->
  Zdigit (ZOdiv n (Zpower beta k')) k = Zdigit n (k + k').
Proof.
intros n k k' Hk Hk'.
unfold Zdigit.
rewrite ZOdiv_ZOdiv.
rewrite Zplus_comm.
now rewrite Zpower_plus.
Qed.

Theorem Zdigit_mod_pow :
  forall n k k', (k < k')%Z ->
  Zdigit (ZOmod n (Zpower beta k')) k = Zdigit n k.
Proof.
intros n k k' Hk.
destruct (Zle_or_lt 0 k) as [H|H].
unfold Zdigit.
rewrite <- 2!ZOdiv_mod_mult.
apply (f_equal (fun x => ZOdiv x (beta ^ k))).
replace k' with (k + 1 + (k' - (k + 1)))%Z by ring.
rewrite Zpower_exp by omega.
rewrite Zmult_comm.
rewrite Zpower_plus by easy.
change (Zpower beta 1) with (beta * 1)%Z.
rewrite Zmult_1_r.
apply ZOmod_mod_mult.
now rewrite 2!Zdigit_lt.
Qed.

Theorem Zdigit_mod_pow_out :
  forall n k k', (0 <= k' <= k)%Z ->
  Zdigit (ZOmod n (Zpower beta k')) k = Z0.
Proof.
intros n k k' Hk.
unfold Zdigit.
rewrite ZOdiv_small_abs.
apply ZOmod_0_l.
apply Zlt_le_trans with (Zpower beta k').
rewrite <- (Zabs_eq (beta ^ k')) at 2 by apply Zpower_ge_0.
apply ZOmod_lt.
apply Zgt_not_eq.
now apply Zpower_gt_0.
now apply Zpower_le.
Qed.

Fixpoint Zsum_digit f k :=
  match k with
  | O => Z0
  | S k => (Zsum_digit f k + f (Z_of_nat k) * Zpower beta (Z_of_nat k))%Z
  end.

Theorem Zsum_digit_digit :
  forall n k,
  Zsum_digit (Zdigit n) k = ZOmod n (Zpower beta (Z_of_nat k)).
Proof.
intros n.
induction k.
apply sym_eq.
apply ZOmod_1_r.
simpl Zsum_digit.
rewrite IHk.
unfold Zdigit.
rewrite <- ZOdiv_mod_mult.
rewrite <- (ZOmod_mod_mult n beta).
rewrite Zmult_comm.
replace (beta ^ Z_of_nat k * beta)%Z with (Zpower beta (Z_of_nat (S k))).
rewrite Zplus_comm, Zmult_comm.
apply sym_eq.
apply ZO_div_mod_eq.
rewrite inj_S.
rewrite <- (Zmult_1_r beta) at 3.
apply Zpower_plus.
apply Zle_0_nat.
easy.
Qed.

Theorem Zpower_gt_id :
  forall n, (n < Zpower beta n)%Z.
Proof.
intros [|n|n] ; try easy.
simpl.
rewrite Zpower_pos_nat.
rewrite Zpos_eq_Z_of_nat_o_nat_of_P.
induction (nat_of_P n).
easy.
rewrite inj_S.
change (Zpower_nat beta (S n0)) with (beta * Zpower_nat beta n0)%Z.
unfold Zsucc.
apply Zlt_le_trans with (beta * (Z_of_nat n0 + 1))%Z.
clear.
apply Zlt_0_minus_lt.
replace (beta * (Z_of_nat n0 + 1) - (Z_of_nat n0 + 1))%Z with ((beta - 1) * (Z_of_nat n0 + 1))%Z by ring.
apply Zmult_lt_0_compat.
cut (2 <= beta)%Z. omega.
apply Zle_bool_imp_le.
apply beta.
apply (Zle_lt_succ 0).
apply Zle_0_nat.
apply Zmult_le_compat_l.
now apply Zlt_le_succ.
apply Zle_trans with 2%Z.
easy.
apply Zle_bool_imp_le.
apply beta.
Qed.

Theorem Zdigit_ext :
  forall n1 n2,
  (forall k, (0 <= k)%Z -> Zdigit n1 k = Zdigit n2 k) ->
  n1 = n2.
Proof.
intros n1 n2 H.
rewrite <- (ZOmod_small_abs n1 (Zpower beta (Zmax (Zabs n1) (Zabs n2)))).
rewrite <- (ZOmod_small_abs n2 (Zpower beta (Zmax (Zabs n1) (Zabs n2)))) at 2.
replace (Zmax (Zabs n1) (Zabs n2)) with (Z_of_nat (Zabs_nat (Zmax (Zabs n1) (Zabs n2)))).
rewrite <- 2!Zsum_digit_digit.
induction (Zabs_nat (Zmax (Zabs n1) (Zabs n2))).
easy.
simpl.
rewrite H, IHn.
apply refl_equal.
apply Zle_0_nat.
rewrite inj_Zabs_nat.
apply Zabs_eq.
apply Zle_trans with (Zabs n1).
apply Zabs_pos.
apply Zle_max_l.
apply Zlt_le_trans with (Zpower beta (Zabs n2)).
apply Zpower_gt_id.
apply Zpower_le.
apply Zle_max_r.
apply Zlt_le_trans with (Zpower beta (Zabs n1)).
apply Zpower_gt_id.
apply Zpower_le.
apply Zle_max_l.
Qed.

Theorem ZOmod_plus_pow_digit :
  forall u v n, (0 <= u * v)%Z ->
  (forall k, (0 <= k < n)%Z -> Zdigit u k = Z0 \/ Zdigit v k = Z0) ->
  ZOmod (u + v) (Zpower beta n) = (ZOmod u (Zpower beta n) + ZOmod v (Zpower beta n))%Z.
Proof.
intros u v n Huv Hd.
destruct (Zle_or_lt 0 n) as [Hn|Hn].
rewrite ZOplus_mod with (1 := Huv).
apply ZOmod_small_abs.
generalize (Zle_refl n).
pattern n at -2 ; rewrite <- Zabs_eq with (1 := Hn).
rewrite <- (inj_Zabs_nat n).
induction (Zabs_nat n) as [|p IHp].
now rewrite 2!ZOmod_1_r.
rewrite <- 2!Zsum_digit_digit.
simpl Zsum_digit.
rewrite inj_S.
intros Hn'.
replace (Zsum_digit (Zdigit u) p + Zdigit u (Z_of_nat p) * beta ^ Z_of_nat p +
  (Zsum_digit (Zdigit v) p + Zdigit v (Z_of_nat p) * beta ^ Z_of_nat p))%Z with
  (Zsum_digit (Zdigit u) p + Zsum_digit (Zdigit v) p +
  (Zdigit u (Z_of_nat p) + Zdigit v (Z_of_nat p)) * beta ^ Z_of_nat p)%Z by ring.
apply (Zle_lt_trans _ _ _ (Zabs_triangle _ _)).
replace (beta ^ Zsucc (Z_of_nat p))%Z with (beta ^ Z_of_nat p + (beta - 1) * beta ^ Z_of_nat p)%Z.
apply Zplus_lt_le_compat.
rewrite 2!Zsum_digit_digit.
apply IHp.
now apply Zle_succ_le.
rewrite Zabs_Zmult.
rewrite (Zabs_eq (beta ^ Z_of_nat p)) by apply Zpower_ge_0.
apply Zmult_le_compat_r. 2: apply Zpower_ge_0.
apply Zlt_succ_le.
assert (forall u v, Zabs (Zdigit u v) < Zsucc (beta -  1))%Z.
clear ; intros n k.
assert (0 < beta)%Z.
apply Zlt_le_trans with 2%Z.
apply refl_equal.
apply Zle_bool_imp_le.
apply beta.
replace (Zsucc (beta - 1)) with (Zabs beta).
apply ZOmod_lt.
now apply Zgt_not_eq.
rewrite Zabs_eq.
apply Zsucc_pred.
now apply Zlt_le_weak.
assert (0 <= Z_of_nat p < n)%Z.
split.
apply Zle_0_nat.
apply Zgt_lt.
now apply Zle_succ_gt.
destruct (Hd (Z_of_nat p) H0) as [K|K] ; rewrite K.
apply H.
rewrite Zplus_0_r.
apply H.
unfold Zsucc.
ring_simplify.
rewrite Zpower_plus.
change (beta ^1)%Z with (beta * 1)%Z.
now rewrite Zmult_1_r.
apply Zle_0_nat.
easy.
destruct n as [|n|n] ; try easy.
now rewrite 3!ZOmod_0_r.
Qed.

Theorem ZOdiv_plus_pow_digit :
  forall u v n, (0 <= u * v)%Z ->
  (forall k, (0 <= k < n)%Z -> Zdigit u k = Z0 \/ Zdigit v k = Z0) ->
  ZOdiv (u + v) (Zpower beta n) = (ZOdiv u (Zpower beta n) + ZOdiv v (Zpower beta n))%Z.
Proof.
intros u v n Huv Hd.
rewrite <- (Zplus_0_r (ZOdiv u (Zpower beta n) + ZOdiv v (Zpower beta n))).
rewrite ZOdiv_plus with (1 := Huv).
rewrite <- ZOmod_plus_pow_digit by assumption.
apply f_equal.
destruct (Zle_or_lt 0 n) as [Hn|Hn].
apply ZOdiv_small_abs.
rewrite <- Zabs_eq.
apply ZOmod_lt.
apply Zgt_not_eq.
now apply Zpower_gt_0.
apply Zpower_ge_0.
clear -Hn.
destruct n as [|n|n] ; try easy.
apply ZOdiv_0_r.
Qed.

Theorem Zdigit_plus :
  forall u v, (0 <= u * v)%Z ->
  (forall k, (0 <= k)%Z -> Zdigit u k = Z0 \/ Zdigit v k = Z0) ->
  forall k,
  Zdigit (u + v) k = (Zdigit u k + Zdigit v k)%Z.
Proof.
intros u v Huv Hd k.
destruct (Zle_or_lt 0 k) as [Hk|Hk].
unfold Zdigit.
rewrite ZOdiv_plus_pow_digit with (1 := Huv).
rewrite <- (Zmult_1_r beta) at 3 5 7.
change (beta * 1)%Z with (beta ^1)%Z.
apply ZOmod_plus_pow_digit.
apply Zsame_sign_trans_weak with v.
intros Zv ; rewrite Zv.
apply ZOdiv_0_l.
rewrite Zmult_comm.
apply Zsame_sign_trans_weak with u.
intros Zu ; rewrite Zu.
apply ZOdiv_0_l.
now rewrite Zmult_comm.
apply Zsame_sign_odiv.
apply Zpower_ge_0.
apply Zsame_sign_odiv.
apply Zpower_ge_0.
intros k' (Hk1,Hk2).
rewrite 2!Zdigit_div_pow by assumption.
apply Hd.
now apply Zplus_le_0_compat.
intros k' (Hk1,Hk2).
now apply Hd.
now rewrite 3!Zdigit_lt.
Qed.

Definition Zscale n k :=
  if Zle_bool 0 k then (n * Zpower beta k)%Z else ZOdiv n (Zpower beta (-k)).

Theorem Zdigit_scale :
  forall n k k', (0 <= k')%Z ->
  Zdigit (Zscale n k) k' = Zdigit n (k' - k).
Proof.
intros n k k' Hk'.
unfold Zscale.
case Zle_bool_spec ; intros Hk.
now apply Zdigit_mul_pow.
apply Zdigit_div_pow with (1 := Hk').
omega.
Qed.

Theorem Zscale_0 :
  forall k,
  Zscale 0 k = Z0.
Proof.
intros k.
unfold Zscale.
case Zle_bool.
apply Zmult_0_l.
apply ZOdiv_0_l.
Qed.

Theorem Zsame_sign_scale :
  forall n k,
  (0 <= n * Zscale n k)%Z.
Proof.
intros n k.
unfold Zscale.
case Zle_bool_spec ; intros Hk.
rewrite Zmult_assoc.
apply Zmult_le_0_compat.
apply Zsame_sign_imp ; apply Zlt_le_weak.
apply Zpower_ge_0.
apply Zsame_sign_odiv.
apply Zpower_ge_0.
Qed.

Theorem Zscale_mul_pow :
  forall n k k', (0 <= k)%Z ->
  Zscale (n * Zpower beta k) k' = Zscale n (k + k').
Proof.
intros n k k' Hk.
unfold Zscale.
case Zle_bool_spec ; intros Hk'.
rewrite Zle_bool_true.
rewrite <- Zmult_assoc.
apply f_equal.
now rewrite Zpower_plus.
now apply Zplus_le_0_compat.
case Zle_bool_spec ; intros Hk''.
pattern k at 1 ; replace k with (k + k' + -k')%Z by ring.
assert (0 <= -k')%Z by omega.
rewrite Zpower_plus by easy.
rewrite Zmult_assoc, ZO_div_mult.
apply refl_equal.
apply Zgt_not_eq.
now apply Zpower_gt_0.
replace (-k')%Z with (-(k+k') + k)%Z by ring.
rewrite Zpower_plus with (2 := Hk).
apply ZOdiv_mult_cancel_r.
apply Zgt_not_eq.
now apply Zpower_gt_0.
omega.
Qed.

Theorem Zscale_scale :
  forall n k k', (0 <= k)%Z ->
  Zscale (Zscale n k) k' = Zscale n (k + k').
Proof.
intros n k k' Hk.
unfold Zscale at 2.
rewrite Zle_bool_true with (1 := Hk).
now apply Zscale_mul_pow.
Qed.

Definition Zslice n k1 k2 :=
  if Zle_bool 0 k2 then ZOmod (Zscale n (-k1)) (Zpower beta k2) else Z0.

Theorem Zdigit_slice :
  forall n k1 k2 k, (0 <= k < k2)%Z ->
  Zdigit (Zslice n k1 k2) k = Zdigit n (k1 + k).
Proof.
intros n k1 k2 k Hk.
unfold Zslice.
rewrite Zle_bool_true.
rewrite Zdigit_mod_pow by apply Hk.
rewrite Zdigit_scale by apply Hk.
unfold Zminus.
now rewrite Zopp_involutive, Zplus_comm.
omega.
Qed.

Theorem Zdigit_slice_out :
  forall n k1 k2 k, (k2 <= k)%Z ->
  Zdigit (Zslice n k1 k2) k = Z0.
Proof.
intros n k1 k2 k Hk.
unfold Zslice.
case Zle_bool_spec ; intros Hk2.
apply Zdigit_mod_pow_out.
now split.
apply Zdigit_0.
Qed.

Theorem Zslice_0 :
  forall k k',
  Zslice 0 k k' = Z0.
Proof.
intros k k'.
unfold Zslice.
case Zle_bool.
rewrite Zscale_0.
apply ZOmod_0_l.
apply refl_equal.
Qed.

Theorem Zsame_sign_slice :
  forall n k k',
  (0 <= n * Zslice n k k')%Z.
Proof.
intros n k k'.
unfold Zslice.
case Zle_bool.
apply Zsame_sign_trans_weak with (Zscale n (-k)).
intros H ; rewrite H.
apply ZOmod_0_l.
apply Zsame_sign_scale.
rewrite Zmult_comm.
apply ZOmod_sgn2.
now rewrite Zmult_0_r.
Qed.

Theorem Zslice_slice :
  forall n k1 k2 k1' k2', (0 <= k1' <= k2)%Z ->
  Zslice (Zslice n k1 k2) k1' k2' = Zslice n (k1 + k1') (Zmin (k2 - k1') k2').
Proof.
intros n k1 k2 k1' k2' Hk1'.
destruct (Zle_or_lt 0 k2') as [Hk2'|Hk2'].
apply Zdigit_ext.
intros k Hk.
destruct (Zle_or_lt (Zmin (k2 - k1') k2') k) as [Hk'|Hk'].
rewrite (Zdigit_slice_out n (k1 + k1')) with (1 := Hk').
destruct (Zle_or_lt k2' k) as [Hk''|Hk''].
now apply Zdigit_slice_out.
rewrite Zdigit_slice by now split.
apply Zdigit_slice_out.
zify ; omega.
rewrite Zdigit_slice by (zify ; omega).
rewrite (Zdigit_slice n (k1 + k1')) by now split.
rewrite Zdigit_slice.
now rewrite Zplus_assoc.
zify ; omega.
unfold Zslice.
rewrite Zmin_r.
now rewrite Zle_bool_false.
omega.
Qed.

Theorem Zslice_mul_pow :
  forall n k k1 k2, (0 <= k)%Z ->
  Zslice (n * Zpower beta k) k1 k2 = Zslice n (k1 - k) k2.
Proof.
intros n k k1 k2 Hk.
unfold Zslice.
case Zle_bool_spec ; intros Hk2.
2: apply refl_equal.
rewrite Zscale_mul_pow with (1 := Hk).
now replace (- (k1 - k))%Z with (k + -k1)%Z by ring.
Qed.

Theorem Zslice_div_pow :
  forall n k k1 k2, (0 <= k)%Z -> (0 <= k1)%Z ->
  Zslice (ZOdiv n (Zpower beta k)) k1 k2 = Zslice n (k1 + k) k2.
Proof.
intros n k k1 k2 Hk Hk1.
unfold Zslice.
case Zle_bool_spec ; intros Hk2.
2: apply refl_equal.
apply (f_equal (fun x => ZOmod x (beta ^ k2))).
unfold Zscale.
case Zle_bool_spec ; intros Hk1'.
replace k1 with Z0 by omega.
case Zle_bool_spec ; intros Hk'.
replace k with Z0 by omega.
simpl.
now rewrite ZOdiv_1_r.
rewrite Zopp_involutive.
apply Zmult_1_r.
rewrite Zle_bool_false by omega.
rewrite 2!Zopp_involutive, Zplus_comm.
rewrite Zpower_plus by assumption.
apply ZOdiv_ZOdiv.
Qed.

Theorem Zslice_scale :
  forall n k k1 k2, (0 <= k1)%Z ->
  Zslice (Zscale n k) k1 k2 = Zslice n (k1 - k) k2.
Proof.
intros n k k1 k2 Hk1.
unfold Zscale.
case Zle_bool_spec; intros Hk.
now apply Zslice_mul_pow.
apply Zslice_div_pow with (2 := Hk1).
omega.
Qed.

Theorem Zslice_div_pow_scale :
  forall n k k1 k2, (0 <= k)%Z ->
  Zslice (ZOdiv n (Zpower beta k)) k1 k2 = Zscale (Zslice n k (k1 + k2)) (-k1).
Proof.
intros n k k1 k2 Hk.
apply Zdigit_ext.
intros k' Hk'.
rewrite Zdigit_scale with (1 := Hk').
unfold Zminus.
rewrite (Zplus_comm k'), Zopp_involutive.
destruct (Zle_or_lt k2 k') as [Hk2|Hk2].
rewrite Zdigit_slice_out with (1 := Hk2).
apply sym_eq.
apply Zdigit_slice_out.
now apply Zplus_le_compat_l.
rewrite Zdigit_slice by now split.
destruct (Zle_or_lt 0 (k1 + k')) as [Hk1'|Hk1'].
rewrite Zdigit_slice by omega.
rewrite Zdigit_div_pow by assumption.
apply f_equal.
ring.
now rewrite 2!Zdigit_lt.
Qed.

Theorem Zplus_slice :
  forall n k l1 l2, (0 <= l1)%Z -> (0 <= l2)%Z ->
  (Zslice n k l1 + Zscale (Zslice n (k + l1) l2) l1)%Z = Zslice n k (l1 + l2).
Proof.
intros n k1 l1 l2 Hl1 Hl2.
clear Hl1.
apply Zdigit_ext.
intros k Hk.
rewrite Zdigit_plus.
rewrite Zdigit_scale with (1 := Hk).
destruct (Zle_or_lt (l1 + l2) k) as [Hk2|Hk2].
rewrite Zdigit_slice_out with (1 := Hk2).
now rewrite 2!Zdigit_slice_out by omega.
rewrite Zdigit_slice with (1 := conj Hk Hk2).
destruct (Zle_or_lt l1 k) as [Hk1|Hk1].
rewrite Zdigit_slice_out with (1 := Hk1).
rewrite Zdigit_slice by omega.
simpl ; apply f_equal.
ring.
rewrite Zdigit_slice with (1 := conj Hk Hk1).
rewrite (Zdigit_lt _ (k - l1)) by omega.
apply Zplus_0_r.
rewrite Zmult_comm.
apply Zsame_sign_trans_weak with n.
intros H ; rewrite H.
apply Zslice_0.
rewrite Zmult_comm.
apply Zsame_sign_trans_weak with (Zslice n (k1 + l1) l2).
intros H ; rewrite H.
apply Zscale_0.
apply Zsame_sign_slice.
apply Zsame_sign_scale.
apply Zsame_sign_slice.
clear k Hk ; intros k Hk.
rewrite Zdigit_scale with (1 := Hk).
destruct (Zle_or_lt l1 k) as [Hk1|Hk1].
left.
now apply Zdigit_slice_out.
right.
apply Zdigit_lt.
omega.
Qed.

Section digits_aux.

Variable p : Z.
Hypothesis Hp : (0 <= p)%Z.

Fixpoint Zdigits_aux (nb pow : Z) (n : nat) { struct n } : Z :=
  match n with
  | O => nb
  | S n => if Zlt_bool p pow then nb else Zdigits_aux (nb + 1) (Zmult beta pow) n
  end.

End digits_aux.
(** Number of digits of an integer *)
Definition Zdigits n :=
  match n with
  | Z0 => Z0
  | Zneg p => Zdigits_aux (Zpos p) 1 beta (digits2_Pnat p)
  | Zpos p => Zdigits_aux n 1 beta (digits2_Pnat p)
  end.

Theorem Zdigits_correct :
  forall n,
  (Zpower beta (Zdigits n - 1) <= Zabs n < Zpower beta (Zdigits n))%Z.
Proof.
cut (forall p, Zpower beta (Zdigits (Zpos p) - 1) <= Zpos p < Zpower beta (Zdigits (Zpos p)))%Z.
intros H [|n|n] ; try exact (H n).
now split.
intros n.
simpl.
(* *)
assert (U: (Zpos n < Zpower beta (Z_of_nat (S (digits2_Pnat n))))%Z).
apply Zlt_le_trans with (1 := proj2 (digits2_Pnat_correct n)).
rewrite Zpower_Zpower_nat.
rewrite Zabs_nat_Z_of_nat.
induction (S (digits2_Pnat n)).
easy.
rewrite 2!(Zpower_nat_S).
apply Zmult_le_compat with (2 := IHn0).
apply Zle_bool_imp_le.
apply beta.
easy.
rewrite <- (Zabs_nat_Z_of_nat n0).
rewrite <- Zpower_Zpower_nat.
apply (Zpower_ge_0 (Build_radix 2 (refl_equal true))).
apply Zle_0_nat.
apply Zle_0_nat.
(* *)
revert U.
rewrite inj_S.
unfold Zsucc.
generalize (digits2_Pnat n).
intros u U.
pattern (radix_val beta) at 2 4 ; replace (radix_val beta) with (Zpower beta 1) by apply Zmult_1_r.
assert (V: (Zpower beta (1 - 1) <= Zpos n)%Z).
now apply (Zlt_le_succ 0).
generalize (conj V U).
clear.
generalize (Zle_refl 1).
generalize 1%Z at 2 3 5 6 7 9 10.
(* *)
induction u.
easy.
rewrite inj_S; unfold Zsucc.
simpl Zdigits_aux.
intros v Hv U.
case Zlt_bool_spec ; intros K.
now split.
pattern (radix_val beta) at 2 5 ; replace (radix_val beta) with (Zpower beta 1) by apply Zmult_1_r.
rewrite <- Zpower_plus.
rewrite Zplus_comm.
apply IHu.
clear -Hv ; omega.
split.
now ring_simplify (1 + v - 1)%Z.
now rewrite Zplus_assoc.
easy.
apply Zle_succ_le with (1 := Hv).
Qed.

Theorem Zdigits_abs :
  forall n, Zdigits (Zabs n) = Zdigits n.
Proof.
now intros [|n|n].
Qed.

Theorem Zdigits_gt_0 :
  forall n, n <> Z0 -> (0 < Zdigits n)%Z.
Proof.
intros n Zn.
rewrite <- (Zdigits_abs n).
assert (Hn: (0 < Zabs n)%Z).
destruct n ; try easy.
now elim Zn.
destruct (Zabs n) as [|p|p] ; try easy ; clear.
simpl.
generalize 1%Z (radix_val beta) (refl_equal Lt : (0 < 1)%Z).
induction (digits2_Pnat p).
easy.
simpl.
intros.
case Zlt_bool.
exact H.
apply IHn.
now apply Zlt_lt_succ.
Qed.

Theorem Zdigits_ge_0 :
  forall n, (0 <= Zdigits n)%Z.
Proof.
intros n.
destruct (Z_eq_dec n 0) as [H|H].
now rewrite H.
apply Zlt_le_weak.
now apply Zdigits_gt_0.
Qed.

Theorem Zdigit_out :
  forall n k, (Zdigits n <= k)%Z ->
  Zdigit n k = Z0.
Proof.
intros n k Hk.
apply Zdigit_ge_Zpower with (2 := Hk).
apply Zdigits_correct.
Qed.

Theorem Zdigit_digits :
  forall n, n <> Z0 ->
  Zdigit n (Zdigits n - 1) <> Z0.
Proof.
intros n Zn.
apply Zdigit_not_0.
apply Zlt_0_le_0_pred.
now apply Zdigits_gt_0.
ring_simplify (Zdigits n - 1 + 1)%Z.
apply Zdigits_correct.
Qed.

Theorem Zdigits_slice :
  forall n k l, (0 <= l)%Z ->
  (Zdigits (Zslice n k l) <= l)%Z.
Proof.
intros n k l Hl.
unfold Zslice.
rewrite Zle_bool_true with (1 := Hl).
destruct (Zdigits_correct (ZOmod (Zscale n (- k)) (Zpower beta l))) as (H1,H2).
apply Zpower_lt_Zpower with beta.
apply Zle_lt_trans with (1 := H1).
rewrite <- (Zabs_eq (beta ^ l)) at 2 by apply Zpower_ge_0.
apply ZOmod_lt.
apply Zgt_not_eq.
now apply Zpower_gt_0.
Qed.

End Fcore_digits.


From Fiat.Narcissus Require Import Examples.TutorialPrelude.

Record msg := { data : list (word 8) }.
Definition format :=
  format_list format_word ◦ data ++
  format_nat 8 ◦ length ◦ data.
Definition invariant (m : msg) := length (m.(data)) < pow2 8.

Definition dec : CorrectAlignedDecoderFor invariant format.
Proof.
  synthesize_aligned_decoder.
Defined.


(* Definition for quorum used in BOSCO *)

Record n_Quorum := Q {q_n : nat; q_m : nat; sq : nat -> (nat -> bool)}.

Definition n_Quorum_valid (q : n_Quorum) :=
  let n := q_n q in
  let m := q_m q in
  let sq := sq q in
  (forall i j, i < m -> j < m -> (exists k, k < n /\ (sq i k) = true /\ (sq j k) = true)).

Fixpoint check_quorum_infer' (n : nat) (q : nat -> bool) (b : nat -> bool) :=
  match n with
  | O => true
  | S n' => if (q n') then (if b n' then check_quorum_infer' n' q b else false) else check_quorum_infer' n' q b
  end.

Definition check_quorum_infer (n : nat) (q : nat -> bool) (b : nat -> option bool) :=
  let bt := (fun i => match b i with | Some true => true | _ => false end ) in
  let bf := (fun i => match b i with | Some false => true | _ => false end) in
  match (check_quorum_infer' n q bt, check_quorum_infer' n q bf) with
  | (true, false) => Some true
  | (false, true) => Some false
  | _ => None
  end.

Record n_CoQuorum := CO_Q {coq_m : nat; coq_sq : nat -> (nat -> bool); coq_k : nat; coq_csq : nat -> (nat -> bool)}.

Definition n_CoQuorum_valid (cq : n_CoQuorum) (n : nat) (exist_cond : nat -> (nat -> option bool) -> Prop) :=
  let m := coq_m cq in
  let sq := coq_sq cq in
  let k := coq_k cq in
  let csq := coq_csq cq in
  (forall s, exist_cond n s -> exists j b0 t, j < k /\ check_quorum_infer n (csq j) s = Some b0 /\ t < n /\ (csq j t) = true) /\
  n_Quorum_valid (Q n m sq) /\
  (forall i j, i < m -> j < k -> (exists t, t < n /\ (sq i t) = true /\ (csq j t) = true)).


(* (c) Copyright Microsoft Corporation and Inria.                       *)
(* You may distribute this file under the terms of the CeCILL-B license *)
Require Import ssreflect ssrfun ssrbool eqtype ssrnat fintype bigop finset.
Require Import binomial fingroup morphism automorphism quotient gfunctor.

(******************************************************************************)
(*   This files contains the proofs of several key properties of commutators, *)
(* including the Hall-Witt identity and the Three Subgroup Lemma.             *)
(*   The definition and notation for both pointwise and set wise commutators  *)
(* ([~x, y, ...] and [~: A, B ,...], respectively) are given in fingroup.v    *)
(* This file defines the derived group series:                                *)
(*           G^`(0) ==  G                                                     *)
(*       G^`(n.+1) == [~: G^`(n), G^`(n)]                                     *)
(* as several classical results involve the (first) derived group G^`(1),     *)
(* such as the equivalence H <| G /\ G / H abelian <-> G^`(1) \subset H. The  *)
(* connection between the derived series and solvable groups will only be     *)
(* established in nilpotent.v, however.                                       *)
(******************************************************************************)

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

Import GroupScope.

Definition derived_at_rec n (gT : finGroupType) (A : {set gT}) :=
  iter n (fun B => [~: B, B]) A.

(* Note: 'nosimpl' MUST be used outside of a section -- the end of section   *)
(* "cooking" destroys it.                                                    *)
Definition derived_at := nosimpl derived_at_rec.

Arguments Scope derived_at [nat_scope _ group_scope].
Notation "G ^` ( n )" := (derived_at n G) : group_scope.

Section DerivedBasics.

Variables gT : finGroupType.
Implicit Type A : {set gT}.
Implicit Types G : {group gT}.

Lemma derg0 A : A^`(0) = A. Proof. by []. Qed.
Lemma derg1 A : A^`(1) = [~: A, A]. Proof. by []. Qed.
Lemma dergSn n A : A^`(n.+1) = [~: A^`(n), A^`(n)]. Proof. by []. Qed.

Lemma der_group_set G n : group_set G^`(n).
Proof. by case: n => [|n]; exact: groupP. Qed.

Canonical derived_at_group G n := Group (der_group_set G n).

End DerivedBasics.

Notation "G ^` ( n )" := (derived_at_group G n) : Group_scope.

Section Basic_commutator_properties.

Variable gT : finGroupType.
Implicit Types x y z : gT.

Lemma conjg_mulR x y : x ^ y = x * [~ x, y].
Proof. by rewrite mulKVg. Qed.

Lemma conjg_Rmul x y : x ^ y = [~ y, x^-1] * x.
Proof. by rewrite commgEr invgK mulgKV. Qed.

Lemma commMgJ x y z : [~ x * y, z] = [~ x, z] ^ y * [~ y, z].
Proof. by rewrite !commgEr conjgM mulgA -conjMg mulgK. Qed.

Lemma commgMJ x y z : [~ x, y * z] = [~ x, z] * [~ x, y] ^ z.
Proof. by rewrite !commgEl conjgM -mulgA -conjMg mulKVg. Qed.

Lemma commMgR x y z : [~ x * y, z] = [~ x, z] * [~ x, z, y] * [~ y, z].
Proof. by rewrite commMgJ conjg_mulR. Qed.

Lemma commgMR x y z : [~ x, y * z] = [~ x, z] * [~ x, y] * [~ x, y, z].
Proof. by rewrite commgMJ conjg_mulR mulgA. Qed.

Lemma Hall_Witt_identity x y z :
  [~ x, y^-1, z] ^ y * [~ y, z^-1, x] ^ z * [~ z, x^-1, y] ^ x = 1.
Proof. (* gsimpl *)
pose a x y z : gT := x * z * y ^ x.
suffices{x y z} hw_aux x y z: [~ x, y^-1, z] ^ y = (a x y z)^-1 * (a y z x).
  by rewrite !hw_aux 2!mulgA !mulgK mulVg.
by rewrite commgEr conjMg -conjgM -conjg_Rmul 2!invMg conjgE !mulgA.
Qed.

(* the following properties are useful for studying p-groups of class 2 *)

Section LeftComm.

Variables (i : nat) (x y : gT).
Hypothesis cxz : commute x [~ x, y].

Lemma commVg : [~ x^-1, y] = [~ x, y]^-1.
Proof.
apply/eqP; rewrite commgEl eq_sym eq_invg_mul invgK mulgA -cxz.
by rewrite -conjg_mulR -conjMg mulgV conj1g.
Qed.

Lemma commXg : [~ x ^+ i, y] = [~ x, y] ^+ i.
Proof.
elim: i => [|i' IHi]; first exact: comm1g.
by rewrite !expgS commMgJ /conjg commuteX // mulKg IHi.
Qed.

End LeftComm.

Section RightComm.

Variables (i : nat) (x y : gT).
Hypothesis cyz : commute y [~ x, y].
Let cyz' := commuteV cyz.

Lemma commgV : [~ x, y^-1] = [~ x, y]^-1.
Proof. by rewrite -invg_comm commVg -(invg_comm x y) ?invgK. Qed.

Lemma commgX : [~ x, y ^+ i] = [~ x, y] ^+ i.
Proof. by rewrite -invg_comm commXg -(invg_comm x y) ?expgVn ?invgK. Qed.

End RightComm.

Section LeftRightComm.

Variables (i j : nat) (x y : gT).
Hypotheses (cxz : commute x [~ x, y]) (cyz : commute y [~ x, y]).

Lemma commXXg : [~ x ^+ i, y ^+ j] = [~ x, y] ^+ (i * j).
Proof. rewrite expgM commgX commXg //; exact: commuteX. Qed.

Lemma expMg_Rmul : (y * x) ^+ i = y ^+ i * x ^+ i * [~ x, y] ^+ 'C(i, 2).
Proof.
rewrite -triangular_sum; symmetry.
elim: i => [|k IHk] /=; first by rewrite big_geq ?mulg1.
rewrite big_nat_recr /= addnC expgD !expgS -{}IHk !mulgA; congr (_ * _).
by rewrite -!mulgA commuteX2 // -commgX // [mulg y]lock 3!mulgA -commgC.
Qed.

End LeftRightComm.

End Basic_commutator_properties.

(***** Set theoretic commutators *****)
Section Commutator_properties.

Variable gT : finGroupType.
Implicit Type (rT : finGroupType) (A B C : {set gT}) (D G H K : {group gT}).

Lemma commG1 A : [~: A, 1] = 1.
Proof. by apply/commG1P; rewrite centsC sub1G. Qed.

Lemma comm1G A : [~: 1, A] = 1.
Proof. by rewrite commGC commG1. Qed.

Lemma commg_sub A B : [~: A, B] \subset A <*> B.
Proof. by rewrite comm_subG // (joing_subl, joing_subr). Qed.

Lemma commg_norml G A : G \subset 'N([~: G, A]).
Proof.
apply/subsetP=> x Gx; rewrite inE -genJ gen_subG.
apply/subsetP=> _ /imsetP[_ /imset2P[y z Gy Az ->] ->].
by rewrite -(mulgK [~ x, z] (_ ^ x)) -commMgJ !(mem_commg, groupMl, groupV).
Qed.

Lemma commg_normr G A : G \subset 'N([~: A, G]).
Proof. by rewrite commGC commg_norml. Qed.

Lemma commg_norm G H : G <*> H \subset 'N([~: G, H]).
Proof. by rewrite join_subG ?commg_norml ?commg_normr. Qed.

Lemma commg_normal G H : [~: G, H] <| G <*> H.
Proof. by rewrite /(_ <| _) commg_sub commg_norm. Qed.

Lemma normsRl A G B : A \subset G -> A \subset 'N([~: G, B]).
Proof. by move=> sAG; exact: subset_trans (commg_norml G B). Qed.

Lemma normsRr A G B : A \subset G -> A \subset 'N([~: B, G]).
Proof. by move=> sAG; exact: subset_trans (commg_normr G B). Qed.

Lemma commg_subr G H : ([~: G, H] \subset H) = (G \subset 'N(H)).
Proof.
rewrite gen_subG; apply/subsetP/subsetP=> [sRH x Gx | nGH xy].
  rewrite inE; apply/subsetP=> _ /imsetP[y Ky ->].
  by rewrite conjg_Rmul groupMr // sRH // mem_imset2 ?groupV.
case/imset2P=> x y Gx Hy ->{xy}.
by rewrite commgEr groupMr // memJ_norm (groupV, nGH).
Qed.

Lemma commg_subl G H : ([~: G, H] \subset G) = (H \subset 'N(G)).
Proof. by rewrite commGC commg_subr. Qed.

Lemma commg_subI A B G H :
  A \subset 'N_G(H) -> B \subset 'N_H(G) -> [~: A, B] \subset G :&: H.
Proof.
rewrite !subsetI -(gen_subG _ 'N(G)) -(gen_subG _ 'N(H)).
rewrite -commg_subr -commg_subl; case/andP=> sAG sRH; case/andP=> sBH sRG.
by rewrite (subset_trans _ sRG) ?(subset_trans _ sRH) ?commgSS ?subset_gen.
Qed.

Lemma quotient_cents2 A B K :
    A \subset 'N(K) -> B \subset 'N(K) ->
  (A / K \subset 'C(B / K)) = ([~: A, B] \subset K).
Proof.
move=> nKA nKB.
by rewrite (sameP commG1P trivgP) /= -quotientR // quotient_sub1 // comm_subG.
Qed.

Lemma quotient_cents2r A B K :
  [~: A, B] \subset K -> (A / K) \subset 'C(B / K).
Proof.
move=> sABK; rewrite -2![_ / _]morphimIdom -!quotientE.
by rewrite quotient_cents2 ?subsetIl ?(subset_trans _ sABK) ?commgSS ?subsetIr.
Qed.

Lemma sub_der1_norm G H : G^`(1) \subset H -> H \subset G -> G \subset 'N(H).
Proof.
by move=> sG'H sHG; rewrite -commg_subr (subset_trans _ sG'H) ?commgS.
Qed.

Lemma sub_der1_normal G H : G^`(1) \subset H -> H \subset G -> H <| G.
Proof. by move=> sG'H sHG; rewrite /(H <| G) sHG sub_der1_norm. Qed.

Lemma sub_der1_abelian G H : G^`(1) \subset H -> abelian (G / H).
Proof. by move=> sG'H; exact: quotient_cents2r. Qed.

Lemma der1_min G H : G \subset 'N(H) -> abelian (G / H) -> G^`(1) \subset H.
Proof. by move=> nHG abGH; rewrite -quotient_cents2. Qed.

Lemma der_abelian n G : abelian (G^`(n) / G^`(n.+1)).
Proof. by rewrite sub_der1_abelian // der_subS. Qed.

Lemma commg_normSl G H K : G \subset 'N(H) -> [~: G, H] \subset 'N([~: K, H]).
Proof. by move=> nHG; rewrite normsRr // commg_subr. Qed.

Lemma commg_normSr G H K : G \subset 'N(H) -> [~: H, G] \subset 'N([~: H, K]).
Proof. by move=> nHG; rewrite !(commGC H) commg_normSl. Qed.

Lemma commMGr G H K : [~: G, K] * [~: H, K] \subset [~: G * H , K].
Proof. by rewrite mul_subG ?commSg ?(mulG_subl, mulG_subr). Qed.

Lemma commMG G H K :
  H \subset 'N([~: G, K]) -> [~: G * H , K] = [~: G, K] * [~: H, K].
Proof.
move=> nRH; apply/eqP; rewrite eqEsubset commMGr andbT.
have nRHK: [~: H, K] \subset 'N([~: G, K]) by rewrite comm_subG ?commg_normr.
have defM := norm_joinEr nRHK; rewrite -defM gen_subG /=.
apply/subsetP=> _ /imset2P[_ z /imset2P[x y Gx Hy ->] Kz ->].
by rewrite commMgJ {}defM mem_mulg ?memJ_norm ?mem_commg // (subsetP nRH).
Qed.

Lemma comm3G1P A B C :
  reflect {in A & B & C, forall h k l, [~ h, k, l] = 1} ([~: A, B, C] :==: 1).
Proof.
have R_C := sameP trivgP commG1P.
rewrite -subG1 R_C gen_subG -{}R_C gen_subG.
apply: (iffP subsetP) => [cABC x y z Ax By Cz | cABC xyz].
  by apply/set1P; rewrite cABC // !mem_imset2.
by case/imset2P=> _ z /imset2P[x y Ax By ->] Cz ->; rewrite cABC.
Qed.

Lemma three_subgroup G H K :
  [~: G, H, K] :=: 1 -> [~: H, K, G] :=: 1-> [~: K, G, H] :=: 1.
Proof.
move/eqP/comm3G1P=> cGHK /eqP/comm3G1P cHKG.
apply/eqP/comm3G1P=> x y z Kx Gy Hz; symmetry.
rewrite -(conj1g y) -(Hall_Witt_identity y^-1 z x) invgK.
by rewrite cGHK ?groupV // cHKG ?groupV // !conj1g !mul1g conjgKV.
Qed.

Lemma der1_joing_cycles (x y : gT) :
  let XY := <[x]> <*> <[y]> in let xy := [~ x, y] in
  xy \in 'C(XY) -> XY^`(1) = <[xy]>.
Proof.
rewrite joing_idl joing_idr /= -sub_cent1 => /norms_gen nRxy.
apply/eqP; rewrite eqEsubset cycle_subG mem_commg ?mem_gen ?set21 ?set22 //.
rewrite der1_min // quotient_gen -1?gen_subG // quotientU abelian_gen.
rewrite /abelian subUset centU !subsetI andbC centsC -andbA -!abelianE.
rewrite !quotient_abelian ?(abelianS (subset_gen _) (cycle_abelian _)) //=.
by rewrite andbb quotient_cents2r ?genS // /commg_set imset2_set1l imset_set1.
Qed.

Lemma commgAC G x y z : x \in G -> y \in G -> z \in G ->
  commute y z -> abelian [~: [set x], G] -> [~ x, y, z] = [~ x, z, y].
Proof.
move=> Gx Gy Gz cyz /centsP cRxG; pose cx' u := [~ x^-1, u].
have xR3 u v: [~ x, u, v] = x^-1 * (cx' u * cx' v) * x ^ (u * v).
  rewrite mulgA -conjg_mulR conjVg [cx' v]commgEl mulgA -invMg.
  by rewrite -mulgA conjgM -conjMg -!commgEl.
suffices RxGcx' u: u \in G -> cx' u \in [~: [set x], G].
  by rewrite !xR3 {}cyz; congr (_ * _ * _); rewrite cRxG ?RxGcx'.
move=> Gu; suffices/groupMl <-: [~ x, u] ^ x^-1 \in [~: [set x], G].
  by rewrite -commMgJ mulgV comm1g group1.
by rewrite memJ_norm ?mem_commg ?set11 // groupV (subsetP (commg_normr _ _)).
Qed.

(* Aschbacher, exercise 3.6 (used in proofs of Aschbacher 24.7 and B & G 1.10 *)
Lemma comm_norm_cent_cent H G K :
    H \subset 'N(G) -> H \subset 'C(K) -> G \subset 'N(K) ->
  [~: G, H] \subset 'C(K).
Proof.
move=> nGH /centsP cKH nKG; rewrite commGC gen_subG centsC.
apply/centsP=> x Kx _ /imset2P[y z Hy Gz ->]; red.
rewrite mulgA -[x * _]cKH ?groupV // -!mulgA; congr (_ * _).
rewrite (mulgA x) (conjgC x) (conjgCV z) 3!mulgA; congr (_ * _).
by rewrite -2!mulgA (cKH y) // -mem_conjg (normsP nKG).
Qed.

Lemma charR H K G : H \char G -> K \char G -> [~: H, K] \char G.
Proof.
case/charP=> sHG chH /charP[sKG chK]; apply/charP.
by split=> [|f infj Gf]; [rewrite comm_subG | rewrite morphimR // chH // chK].
Qed.

Lemma der_char n G : G^`(n) \char G.
Proof. by elim: n => [|n IHn]; rewrite ?char_refl // dergSn charR. Qed.

Lemma der_sub n G : G^`(n) \subset G.
Proof. by rewrite char_sub ?der_char. Qed.

Lemma der_norm n G : G \subset 'N(G^`(n)).
Proof. by rewrite char_norm ?der_char. Qed.

Lemma der_normal n G : G^`(n) <| G.
Proof. by rewrite char_normal ?der_char. Qed.

Lemma der_subS n G : G^`(n.+1) \subset G^`(n).
Proof. by rewrite comm_subG. Qed.

Lemma der_normalS n G : G^`(n.+1) <| G^`(n).
Proof. by rewrite sub_der1_normal // der_subS. Qed.

Lemma morphim_der rT D (f : {morphism D >-> rT}) n G :
   G \subset D -> f @* G^`(n) = (f @* G)^`(n).
Proof.
move=> sGD; elim: n => // n IHn.
by rewrite !dergSn -IHn morphimR ?(subset_trans (der_sub n G)).
Qed.

Lemma dergS n G H : G \subset H -> G^`(n) \subset H^`(n).
Proof. by move=> sGH; elim: n => // n IHn; exact: commgSS. Qed.

Lemma quotient_der n G H : G \subset 'N(H) -> G^`(n) / H = (G / H)^`(n).
Proof. exact: morphim_der. Qed.

Lemma derJ G n x : (G :^ x)^`(n) = G^`(n) :^ x.
Proof. by elim: n => //= n IHn; rewrite !dergSn IHn -conjsRg. Qed.

Lemma derG1P G : reflect (G^`(1) = 1) (abelian G).
Proof. exact: commG1P. Qed.

End Commutator_properties.

Implicit Arguments derG1P [gT G].

Lemma der_cont n : GFunctor.continuous (derived_at n).
Proof. by move=> aT rT G f; rewrite morphim_der. Qed.

Canonical der_igFun n := [igFun by der_sub^~ n & der_cont n].
Canonical der_gFun n := [gFun by der_cont n].
Canonical der_mgFun n := [mgFun by dergS^~ n].

Lemma isog_der (aT rT : finGroupType) n (G : {group aT}) (H : {group rT}) :
  G \isog H -> G^`(n) \isog H^`(n).
Proof. exact: gFisog. 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 GNU General Public License as published by  *)
(*  the Free Software Foundation, either version 2 of the License, or  *)
(*  (at your option) any later version.  This file is also distributed *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** A heap data structure. *)

(** The implementation uses splay heaps, following C. Okasaki,
    "Purely functional data structures", section 5.4.
    One difference: we eliminate duplicate elements.
    (If an element is already in a heap, inserting it again does nothing.)
*)

Require Import FunInd.
From CompCert Require Import Coqlib Ordered.
Require Import FSets.

(* To avoid useless definitions of inductors in extracted code. *)
Local Unset Elimination Schemes.
Local Unset Case Analysis Schemes.

Module SplayHeapSet(E: OrderedType).

(** "Raw" implementation.  The "is a binary search tree" invariant
    is proved separately. *)

Module R.

Inductive heap: Type :=
  | Empty
  | Node (l: heap) (x: E.t) (r: heap).

Fixpoint partition (pivot: E.t) (h: heap) { struct h } : heap * heap :=
  match h with
  | Empty => (Empty, Empty)
  | Node a x b =>
      match E.compare x pivot with
      | EQ _ => (a, b)
      | LT _ =>
        match b with
        | Empty => (h, Empty)
        | Node b1 y b2 =>
            match E.compare y pivot with
            | EQ _ => (Node a x b1, b2)
            | LT _ =>
              let (small, big) := partition pivot b2
              in (Node (Node a x b1) y small, big)
            | GT _ =>
              let (small, big) := partition pivot b1
              in (Node a x small, Node big y b2)
            end
        end
     | GT _ =>
        match a with
        | Empty => (Empty, h)
        | Node a1 y a2 =>
            match E.compare y pivot with
            | EQ _ => (a1, Node a2 x b)
            | LT _ =>
              let (small, big) := partition pivot a2
              in (Node a1 y small, Node big x b)
            | GT _ =>
              let (small, big) := partition pivot a1
              in (small, Node big y (Node a2 x b))
            end
        end
    end
  end.

Definition insert (x: E.t) (h: heap) : heap :=
  let (a, b) := partition x h in Node a x b.

Fixpoint findMin (h: heap) : option E.t :=
  match h with
  | Empty => None
  | Node Empty x b => Some x
  | Node a x b => findMin a
  end.

Fixpoint deleteMin (h: heap) : heap :=
  match h with
  | Empty => Empty
  | Node Empty x b => b
  | Node (Node Empty x b) y c => Node b y c
  | Node (Node a x b) y c => Node (deleteMin a) x (Node b y c)
  end.

Fixpoint findMax (h: heap) : option E.t :=
  match h with
  | Empty => None
  | Node a x Empty => Some x
  | Node a x b => findMax b
  end.

Fixpoint deleteMax (h: heap) : heap :=
  match h with
  | Empty => Empty
  | Node b x Empty => b
  | Node b x (Node c y Empty) => Node b x c
  | Node a x (Node b y c) => Node (Node a x b) y (deleteMax c)
  end.

(** Induction principles for some of the operators. *)

Scheme heap_ind := Induction for heap Sort Prop.
Functional Scheme partition_ind := Induction for partition Sort Prop.
Functional Scheme deleteMin_ind := Induction for deleteMin Sort Prop.
Functional Scheme deleteMax_ind := Induction for deleteMax Sort Prop.

(** Specification *)

Fixpoint In (x: E.t) (h: heap) : Prop :=
  match h with
  | Empty => False
  | Node a y b => In x a \/ E.eq x y \/ In x b
  end.

(** Invariants *)

Fixpoint lt_heap (h: heap) (x: E.t) : Prop :=
  match h with
  | Empty => True
  | Node a y b => lt_heap a x /\ E.lt y x /\ lt_heap b x
  end.

Fixpoint gt_heap (h: heap) (x: E.t) : Prop :=
  match h with
  | Empty => True
  | Node a y b => gt_heap a x /\ E.lt x y /\ gt_heap b x
  end.

Fixpoint bst (h: heap) : Prop :=
  match h with
  | Empty => True
  | Node a x b => bst a /\ bst b /\ lt_heap a x /\ gt_heap b x
  end.

Definition le (x y: E.t) := E.eq x y \/ E.lt x y.

Lemma le_lt_trans:
  forall x1 x2 x3, le x1 x2 -> E.lt x2 x3 -> E.lt x1 x3.
Proof.
  unfold le; intros; intuition.
  destruct (E.compare x1 x3).
    auto.
    elim (@E.lt_not_eq x2 x3). auto. apply E.eq_trans with x1. apply E.eq_sym; auto. auto.
    elim (@E.lt_not_eq x2 x1). eapply E.lt_trans; eauto. apply E.eq_sym; auto.
    eapply E.lt_trans; eauto.
Qed.

Lemma lt_le_trans:
  forall x1 x2 x3, E.lt x1 x2 -> le x2 x3 -> E.lt x1 x3.
Proof.
  unfold le; intros; intuition.
  destruct (E.compare x1 x3).
    auto.
    elim (@E.lt_not_eq x1 x2). auto. apply E.eq_trans with x3. auto. apply E.eq_sym; auto.
    elim (@E.lt_not_eq x3 x2). eapply E.lt_trans; eauto. apply E.eq_sym; auto.
    eapply E.lt_trans; eauto.
Qed.

Lemma le_trans:
  forall x1 x2 x3, le x1 x2 -> le x2 x3 -> le x1 x3.
Proof.
  intros. destruct H. destruct H0. red; left; eapply E.eq_trans; eauto.
  red. right. eapply le_lt_trans; eauto. red; auto.
  red. right. eapply lt_le_trans; eauto.
Qed.

Lemma lt_heap_trans:
  forall x y, le x y ->
  forall h, lt_heap h x -> lt_heap h y.
Proof.
  induction h; simpl; intros.
  auto.
  intuition. eapply lt_le_trans; eauto.
Qed.

Lemma gt_heap_trans:
  forall x y, le y x ->
  forall h, gt_heap h x -> gt_heap h y.
Proof.
  induction h; simpl; intros.
  auto.
  intuition. eapply le_lt_trans; eauto.
Qed.

(** Properties of [partition] *)

Lemma In_partition:
  forall x pivot, ~E.eq x pivot ->
  forall h, bst h -> (In x h <-> In x (fst (partition pivot h)) \/ In x (snd (partition pivot h))).
Proof.
  intros x pivot NEQ h0. functional induction (partition pivot h0); simpl; intros.
- tauto.
- tauto.
- rewrite e3 in *; simpl in *; intuition.
- intuition. elim NEQ. eapply E.eq_trans; eauto.
- rewrite e3 in *; simpl in *; intuition.
- intuition. elim NEQ. eapply E.eq_trans; eauto.
- intuition.
- rewrite e3 in *; simpl in *; intuition.
- intuition. elim NEQ. eapply E.eq_trans; eauto.
- rewrite e3 in *; simpl in *; intuition.
Qed.

Lemma partition_lt:
  forall x pivot h,
  lt_heap h x -> lt_heap (fst (partition pivot h)) x /\ lt_heap (snd (partition pivot h)) x.
Proof.
  intros x pivot h0. functional induction (partition pivot h0); simpl; try tauto.
- rewrite e3 in *; simpl in *; tauto.
- rewrite e3 in *; simpl in *; tauto.
- rewrite e3 in *; simpl in *; tauto.
- rewrite e3 in *; simpl in *; tauto.
Qed.

Lemma partition_gt:
  forall x pivot h,
  gt_heap h x -> gt_heap (fst (partition pivot h)) x /\ gt_heap (snd (partition pivot h)) x.
Proof.
  intros x pivot h0. functional induction (partition pivot h0); simpl; try tauto.
- rewrite e3 in *; simpl in *; tauto.
- rewrite e3 in *; simpl in *; tauto.
- rewrite e3 in *; simpl in *; tauto.
- rewrite e3 in *; simpl in *; tauto.
Qed.

Lemma partition_split:
  forall pivot h,
  bst h -> lt_heap (fst (partition pivot h)) pivot /\ gt_heap (snd (partition pivot h)) pivot.
Proof.
  intros pivot h0. functional induction (partition pivot h0); simpl.
- tauto.
- intuition. eapply lt_heap_trans; eauto. red; auto.
- rewrite e3 in *; simpl in *. intuition.
  eapply lt_heap_trans; eauto. red; auto.
  eapply lt_heap_trans; eauto. red; auto.
- intuition.
  eapply lt_heap_trans; eauto. red; auto.
  eapply lt_heap_trans; eauto. red; auto.
  eapply gt_heap_trans with y; eauto. red. left. apply E.eq_sym; auto.
- rewrite e3 in *; simpl in *; intuition.
  eapply lt_heap_trans; eauto. red; auto.
  eapply gt_heap_trans with y; eauto. red; auto.
- intuition.
  eapply lt_heap_trans; eauto. red; auto.
  eapply gt_heap_trans; eauto. red; auto with ordered_type.
- intuition. eapply gt_heap_trans; eauto. red; auto.
- rewrite e3 in *; simpl in *. intuition.
  eapply lt_heap_trans with y; eauto. red; auto.
  eapply gt_heap_trans; eauto. red; auto.
- intuition.
  eapply lt_heap_trans with y; eauto. red; auto.
  eapply gt_heap_trans; eauto. red; auto with ordered_type.
  eapply gt_heap_trans with x; eauto. red; auto.
- rewrite e3 in *; simpl in *; intuition.
  eapply gt_heap_trans; eauto. red; auto.
  eapply gt_heap_trans; eauto. red; auto.
Qed.

Lemma partition_bst:
  forall pivot h,
  bst h ->
  bst (fst (partition pivot h)) /\ bst (snd (partition pivot h)).
Proof.
  intros pivot h0. functional induction (partition pivot h0); simpl; try tauto.
- rewrite e3 in *; simpl in *. intuition.
    apply lt_heap_trans with x; auto. red; auto.
    generalize (partition_gt y pivot b2 H7). rewrite e3; simpl. tauto.
- rewrite e3 in *; simpl in *. intuition.
    generalize (partition_gt x pivot b1 H3). rewrite e3; simpl. tauto.
    generalize (partition_lt y pivot b1 H4). rewrite e3; simpl. tauto.
- rewrite e3 in *; simpl in *. intuition.
    generalize (partition_gt y pivot a2 H6). rewrite e3; simpl. tauto.
    generalize (partition_lt x pivot a2 H8). rewrite e3; simpl. tauto.
- rewrite e3 in *; simpl in *. intuition.
    generalize (partition_lt y pivot a1 H3). rewrite e3; simpl. tauto.
    apply gt_heap_trans with x; auto. red; auto.
Qed.

(** Properties of [insert] *)

Lemma insert_bst:
  forall x h, bst h -> bst (insert x h).
Proof.
  intros.
  unfold insert. case_eq (partition x h). intros a b EQ; simpl.
  generalize (partition_bst x h H).
  generalize (partition_split x h H).
  rewrite EQ; simpl. tauto.
Qed.

Lemma In_insert:
  forall x h y, bst h -> (In y (insert x h) <-> E.eq y x \/ In y h).
Proof.
  intros. unfold insert.
  case_eq (partition x h). intros a b EQ; simpl.
  assert (E.eq y x \/ ~E.eq y x).
    destruct (E.compare y x); auto with ordered_type.
    right; red; intros. elim (E.lt_not_eq l). apply E.eq_sym; auto.
  destruct H0.
  tauto.
  generalize (In_partition y x H0 h H). rewrite EQ; simpl. tauto.
Qed.

(** Properties of [findMin] and [deleteMin] *)

Lemma deleteMin_lt:
  forall x h, lt_heap h x -> lt_heap (deleteMin h) x.
Proof.
Opaque deleteMin.
  intros x h0. functional induction (deleteMin h0) ; simpl; intros.
  auto.
  tauto.
  tauto.
  intuition. apply IHh. simpl. tauto.
Qed.

Lemma deleteMin_bst:
  forall h, bst h -> bst (deleteMin h).
Proof.
  intros h0. functional induction (deleteMin h0); simpl; intros.
  auto.
  tauto.
  tauto.
  intuition.
  apply IHh. simpl; auto.
  apply deleteMin_lt; auto. simpl; auto.
  apply gt_heap_trans with y; auto. red; auto.
Qed.

Lemma In_deleteMin:
  forall y x h,
  findMin h = Some x ->
  (In y h <-> E.eq y x \/ In y (deleteMin h)).
Proof.
Transparent deleteMin.
  intros y x h0. functional induction (deleteMin h0); simpl; intros.
  discriminate.
  inv H. tauto.
  inv H. tauto.
  destruct _x. inv H. simpl. tauto. generalize (IHh H). simpl. tauto.
Qed.

Lemma gt_heap_In:
  forall x y h, gt_heap h x -> In y h -> E.lt x y.
Proof.
  induction h; simpl; intros.
  contradiction.
  intuition. apply lt_le_trans with x0; auto. red. left. apply E.eq_sym; auto.
Qed.

Lemma findMin_min:
  forall x h, findMin h = Some x -> bst h -> forall y, In y h -> le x y.
Proof.
  induction h; simpl; intros.
  contradiction.
  destruct h1.
  inv H. simpl in *. intuition.
  red; left; apply E.eq_sym; auto.
  red; right. eapply gt_heap_In; eauto.
  assert (le x x1).
    apply IHh1; auto. tauto. simpl. right; left; apply E.eq_refl.
  intuition.
  apply le_trans with x1. auto.  apply le_trans with x0. simpl in H4. red; tauto.
  red; left; apply E.eq_sym; auto.
  apply le_trans with x1. auto. apply le_trans with x0. simpl in H4. red; tauto.
  red; right. eapply gt_heap_In; eauto.
Qed.

Lemma findMin_empty:
  forall h, h <> Empty -> findMin h <> None.
Proof.
  induction h; simpl; intros.
  congruence.
  destruct h1. congruence. apply IHh1. congruence.
Qed.

(** Properties of [findMax] and [deleteMax]. *)

Lemma deleteMax_gt:
  forall x h, gt_heap h x -> gt_heap (deleteMax h) x.
Proof.
Opaque deleteMax.
  intros x h0. functional induction (deleteMax h0); simpl; intros.
  auto.
  tauto.
  tauto.
  intuition. apply IHh. simpl. tauto.
Qed.

Lemma deleteMax_bst:
  forall h, bst h -> bst (deleteMax h).
Proof.
  intros h0. functional induction (deleteMax h0); simpl; intros.
  auto.
  tauto.
  tauto.
  intuition.
    apply IHh. simpl; auto.
    apply lt_heap_trans with x; auto. red; auto.
    apply deleteMax_gt; auto. simpl; auto.
Qed.

Lemma In_deleteMax:
  forall y x h,
  findMax h = Some x ->
  (In y h <-> E.eq y x \/ In y (deleteMax h)).
Proof.
Transparent deleteMax.
  intros y x h0. functional induction (deleteMax h0); simpl; intros.
  congruence.
  inv H. tauto.
  inv H. tauto.
  destruct _x1. inv H. simpl. tauto. generalize (IHh H). simpl. tauto.
Qed.

Lemma lt_heap_In:
  forall x y h, lt_heap h x -> In y h -> E.lt y x.
Proof.
  induction h; simpl; intros.
  contradiction.
  intuition. apply le_lt_trans with x0; auto. red. left. assumption.
Qed.

Lemma findMax_max:
  forall x h, findMax h = Some x -> bst h -> forall y, In y h -> le y x.
Proof.
  induction h; simpl; intros.
  contradiction.
  destruct h2.
  inv H. simpl in *. intuition.
  red; right. eapply lt_heap_In; eauto.
  red; left. auto.
  assert (le x1 x).
    apply IHh2; auto. tauto. simpl. right; left; apply E.eq_refl.
  intuition.
  apply le_trans with x1; auto.  apply le_trans with x0.
  red; right. eapply lt_heap_In; eauto.
  simpl in H6. red; tauto.
  apply le_trans with x1; auto. apply le_trans with x0.
  red; auto.
  simpl in H6. red; tauto.
Qed.

Lemma findMax_empty:
  forall h, h <> Empty -> findMax h <> None.
Proof.
  induction h; simpl; intros.
  congruence.
  destruct h2. congruence. apply IHh2. congruence.
Qed.

End R.

(** Wrapping in a dependent type *)

Definition t := { h: R.heap | R.bst h }.

(** Operations *)

Program Definition empty : t := R.Empty.

Program Definition insert (x: E.t) (h: t) : t := R.insert x h.
Next Obligation. apply R.insert_bst. apply proj2_sig. Qed.

Program Definition findMin (h: t) : option E.t := R.findMin h.

Program Definition deleteMin (h: t) : t := R.deleteMin h.
Next Obligation. apply R.deleteMin_bst. apply proj2_sig. Qed.

Program Definition findMax (h: t) : option E.t := R.findMax h.

Program Definition deleteMax (h: t) : t := R.deleteMax h.
Next Obligation. apply R.deleteMax_bst. apply proj2_sig. Qed.

(** Membership (for specification) *)

Program Definition In (x: E.t) (h: t) : Prop := R.In x h.

(** Properties of [empty] *)

Lemma In_empty: forall x, ~In x empty.
Proof.
  intros; red; intros.
  red in H. simpl in H. tauto.
Qed.

(** Properties of [insert] *)

Lemma In_insert:
  forall x h y,
  In y (insert x h) <-> E.eq y x \/ In y h.
Proof.
  intros. unfold In, insert; simpl. apply R.In_insert. apply proj2_sig.
Qed.

(** Properties of [findMin] *)

Lemma findMin_empty:
  forall h y, findMin h = None -> ~In y h.
Proof.
  unfold findMin, In; intros; simpl.
  destruct (proj1_sig h).
  simpl. tauto.
  exploit R.findMin_empty; eauto. congruence.
Qed.

Lemma findMin_min:
  forall h x y, findMin h = Some x -> In y h -> E.eq x y \/ E.lt x y.
Proof.
  unfold findMin, In; simpl. intros.
  change (R.le x y). eapply R.findMin_min; eauto. apply proj2_sig.
Qed.

(** Properties of [deleteMin]. *)

Lemma In_deleteMin:
  forall h x y,
  findMin h = Some x ->
  (In y h <-> E.eq y x \/ In y (deleteMin h)).
Proof.
  unfold findMin, In; simpl; intros.
  apply R.In_deleteMin. auto.
Qed.

(** Properties of [findMax] *)

Lemma findMax_empty:
  forall h y, findMax h = None -> ~In y h.
Proof.
  unfold findMax, In; intros; simpl.
  destruct (proj1_sig h).
  simpl. tauto.
  exploit R.findMax_empty; eauto. congruence.
Qed.

Lemma findMax_max:
  forall h x y, findMax h = Some x -> In y h -> E.eq y x \/ E.lt y x.
Proof.
  unfold findMax, In; simpl. intros.
  change (R.le y x). eapply R.findMax_max; eauto. apply proj2_sig.
Qed.

(** Properties of [deleteMax]. *)

Lemma In_deleteMax:
  forall h x y,
  findMax h = Some x ->
  (In y h <-> E.eq y x \/ In y (deleteMax h)).
Proof.
  unfold findMax, In; simpl; intros.
  apply R.In_deleteMax. auto.
Qed.

End SplayHeapSet.

(** Instantiation over type [positive] *)

Module PHeap := SplayHeapSet(OrderedPositive).


Require Import Bool.

(**some compute*)
(*** ===========================================================*)
(*two number equal*)
Fixpoint eqb (n m : nat) : bool :=
  match n with
  | O => match m with
         | O => true
         | S m' => false
         end
  | S n' => match m with
            | O => false
            | S m' => eqb n' m'
            end
  end.

Fixpoint leb (n m : nat) : bool :=
  match n with
  | O => true
  | S n' =>
      match m with
      | O => false
      | S m' => leb n' m'
      end
  end.

Notation "x =? y" := (eqb x y) (at level 70) : nat_scope.
Notation "x <=? y" := (leb x y) (at level 70) : nat_scope.

(**Block*)
(*** ===========================================================*)

Inductive FlagB : Type :=
  | busy
  | free.

Definition flagSame (st1 st2 : FlagB) : bool :=
  match st1 with
  | busy => match st2 with
            | busy => true
            | free => false
            end
  | free => match st2 with
            | busy => false
            | free => true
            end
  end.

Inductive Block : Type :=
  | block (flag: FlagB)(first size: nat).

Notation "( f , x , y )" := (block f x y).

(*Block status*)
Definition bflag (b : Block) : FlagB :=
  match b with
  | (f, a, s) => f
  end.

(*Block address*)
Definition badd (b : Block) : nat :=
  match b with
  | (f, a, d) => a
  end.

(*Block size*)
Definition bsize (b : Block) : nat :=
  match b with
  | (f, a, s) => s
  end.

Definition block_from_zero (b : Block) : bool :=
  match b with
  | (_, O, _) => true
  | (_, _, _) => false
  end.

Definition block_empty (b : Block) : bool :=
  match b with
  | (_, _, O) => true
  | (_, _, _) => false
  end.

Definition eqblock (b1 b2 : Block) : bool :=
  match b1 with (_, a1, s1) => match b2 with (_, a2, s2) =>
  match a1 =? a2 with
  | true => match s1 =? s2 with
            | true => true
            | false => false
            end
  | false => false
  end
  end
  end.

Definition eqblock_state (b1 b2 : Block) : bool :=
  match b1 with (st1, a1, s1) => match b2 with (st2, a2, s2) =>
  match (flagSame st1 st2) with
  | true => match a1 =? a2 with
          | true => match s1 =? s2 with
                    | true => true
                    | false => false
                    end
          | false => false
          end
  | false => false
  end
  end
  end.

Definition eqblock_busy (b1 b2 : Block) : bool :=
  match b1 with (st1, a1, s1) => match b2 with (st2, a2, s2) =>
  match st1 with
  | busy => match (flagSame st1 st2) with
            | true => match a1 =? a2 with
                    | true => match s1 =? s2 with
                              | true => true
                              | false => false
                              end
                    | false => false
                    end
            | false => false
            end
  | free => false
  end
  end
  end.

(**BlockList definition*)
(*** ===========================================================*)
Inductive blocklist : Set :=
  | block_nil
  | block_cons (b : Block) (l : blocklist).

Notation "b :: l" := (block_cons b l).
Notation "[ ]" := block_nil.
Notation "[ x ; .. ; y ]" := (block_cons x .. (block_cons y block_nil) ..).

Fixpoint eqblocklist (l1 l2:blocklist) : bool :=
  match l1 with
  | block_nil => match l2 with
           | block_nil => true
           | h2 :: t2 => false
           end
  | h1 :: t1 => match l2 with
                | block_nil => false
                | h2 :: t2 => match (eqblock h1 h2) with
                              | true => eqblocklist t1 t2
                              | false => false
                              end
                end
  end.

Definition bl_first (l : blocklist): Block :=
  match l with
  | block_nil => (free, O, O)
  | h :: t => h
  end.

Eval compute in bl_first [(free, 1, 45);(busy, 6, 15)].

Fixpoint appbl (l1 l2 : blocklist) : blocklist :=
  match l1 with
  | block_nil    => l2
  | h :: t => h :: (appbl t l2)
  end.

Notation "x ++ y" := (appbl x y).

Fixpoint rev (l : blocklist) : blocklist :=
  match l with
  | block_nil    => block_nil
  | h :: t => rev t ++ [h]
  end.

Definition bl_end (l : blocklist): Block :=
  match rev l with
  | block_nil => (free, O, O)
  | h :: t => h
  end.

Eval compute in bl_end [(free, 1, 45);(busy, 6, 15)].

Definition bl_not_empty (l : blocklist): bool :=
  match bl_end l with
  | (_, O, O) => false
  | (_, _, _) => true
  end.

Definition block_form_list (b: Block)(l: blocklist): bool :=
  match l with
  | block_nil => true
  | h :: t => if (badd b) =? (badd h) + (bsize h) then true else false
  end.

Fixpoint busy_block_in_list (b : Block) (l : blocklist) : bool :=
  match l with
  | block_nil => false
  | h :: t => if (eqblock_busy h b) then true
                                    else busy_block_in_list b t
  end.

(**function*)
(*** ===========================================================*)

(*operation allocate*)
Definition allocate (r : nat) (l : blocklist) : blocklist :=
  match r with
  | O => l
  | _ => match bl_first l with
         | (_, a, d) => (busy, a+d, r) :: l
         end
  end.

Eval compute in allocate 0 ((busy, 59, 20) :: [(free, 14, 45);(busy, 0, 14)]).

Eval compute in allocate 5 ((busy, 59, 20) :: [(free, 14, 45);(busy, 0, 14)]).

Definition bust_to_free (b : Block) : Block :=
  match b with
  | (_, a, s) => (free, a, s)
  end.

(*operation free*)
Fixpoint release (b : Block) (l : blocklist) : blocklist :=
  match l with
  | block_nil => block_nil
  | h :: t => if (eqblock h b) then (bust_to_free h) :: t
                               else h :: (release b t)
  end.

Eval compute in release (busy, 59, 20) ((busy, 59, 20) :: [(free, 14, 45);(busy, 0, 14)]).

Hint Resolve allocate bust_to_free release : memorymanage.

(**character*)
(*** ===========================================================*)

(*1.memory address is nature from 0*)
Definition list_from_zero (l : blocklist) : bool :=
  match l with
  | block_nil => true
  | h :: t => block_from_zero (bl_end l)
  end.

Eval compute in list_from_zero ((busy, 59, 20) :: [(free, 14, 45);(busy, 0, 14)]).

(*2.blocklist tail address less memory size*)
Definition list_tail_less_memory_size (l : blocklist) (mz : nat) : bool :=
  match l with
  | block_nil => true
  | h :: t => if (badd(h) + bsize(h)) <=? mz then true
                                          else false
  end.

Eval compute in list_tail_less_memory_size ((busy, 59, 20) :: [(free, 14, 45);(busy, 0, 14)]) 87.

(*3.between Blocks have no gap; memory block is continue*)
Fixpoint list_not_gap (l : blocklist) : bool :=
  match l with
  | block_nil => true
  | h :: t => match (block_form_list h t) with
              | true => list_not_gap t
              | false => false
              end
  end.

Eval compute in list_not_gap ((busy, 59, 20) :: [(free, 14, 45);(busy, 0, 14)]).

(*4.no zero Block*)
Fixpoint list_not_zeroB (l : blocklist) : bool :=
  match l with
  | block_nil => true
  | h :: t => match (block_empty h) with
              | true => false
              | false => list_not_zeroB t
              end
  end.

Hint Resolve list_from_zero list_not_gap list_not_zeroB : memorymanage.

Let H1 := [(busy, 68, 10);(busy, 48, 20);(busy, 37, 11);(busy, 19, 18);(busy, 6, 13);(busy, 0, 6)].
Eval compute in list_from_zero H1.
Eval compute in list_tail_less_memory_size H1 80.
Eval compute in list_not_gap H1.
Eval compute in list_not_zeroB H1.


From Coqprime Require Import PocklingtonRefl.
Local Open Scope positive_scope.

Lemma primo80:
  prime  2387947357->
  prime  150794520695308537.
Proof.
intro H.
apply (Pocklington_refl
     (Ell_certif
      150794520695308537
      63148176
      ((2387947357,1)::nil)
      0
      221184
      48
      576)
     ((Proof_certif _ H) :: nil)).
native_cast_no_check (refl_equal true).
Time Qed.


Require Import Coq.ZArith.BinInt.
Require Import riscv.Utility.Encode.
Require Import coqutil.Z.BitOps.
Require Import coqutil.Z.prove_Zeq_bitwise.

Lemma invert_encode_R_atomic: forall {opcode rd rs1 rs2 funct3 aqrl funct5},
  verify_R_atomic opcode rd rs1 rs2 funct3 aqrl funct5 ->
  forall inst,
  encode_R_atomic opcode rd rs1 rs2 funct3 aqrl funct5 = inst ->
  opcode = bitSlice inst 0 7 /\
  funct3 = bitSlice inst 12 15 /\
  aqrl = bitSlice inst 25 27 /\
  funct5 = bitSlice inst 27 32 /\
  rd = bitSlice inst 7 12 /\
  rs1 = bitSlice inst 15 20 /\
  rs2 = bitSlice inst 20 25.
Proof. intros. unfold encode_R_atomic, verify_R_atomic in *. prove_Zeq_bitwise. Qed.


Set Implicit Arguments.

Require Import Coq.Structures.OrderedType.

Module GLabel_as_MOT <: MiniOrderedType.

  Require Import Bedrock.Platform.Cito.GLabel.

  Definition t := glabel.

  Definition eq := @eq t.

  Require Import Bedrock.LabelMap.

  Definition to_bl (lbl : t) : Labels.label := (fst lbl, Labels.Global (snd lbl)).

  Definition lt (x y : t) := LabelKey.lt (to_bl x) (to_bl y).

  Lemma eq_refl : forall x : t, eq x x.
    unfold eq; eauto.
  Qed.

  Lemma eq_sym : forall x y : t, eq x y -> eq y x.
    unfold eq; eauto.
  Qed.

  Lemma eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z.
    unfold eq; intuition.
    congruence.
  Qed.

  Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z.
    unfold lt; intros.
    eapply LabelKey.lt_trans; eauto.
  Qed.

  Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
    unfold lt; unfold eq; intuition.
    subst.
    eapply LabelKey.lt_not_eq in H.
    contradict H.
    unfold LabelKey.eq.
    eauto.
  Qed.

  Definition compare : forall x y : t, Compare lt eq x y.
    unfold lt; unfold eq.
    intros.
    destruct (LabelKey.compare (to_bl x) (to_bl y)).
    econstructor 1; eauto.
    econstructor 2; eauto.
    unfold LabelKey.eq in *.
    unfold to_bl in *.
    destruct x; destruct y; simpl in *.
    injection e; intros; subst.
    eauto.
    econstructor 3; eauto.
  Defined.

End GLabel_as_MOT.

Module GLabel_as_OT := MOT_to_OT GLabel_as_MOT.
Require Import Coq.Structures.OrdersAlt.
Module GLabel_as_OT_new := Update_OT GLabel_as_OT.
Require Import Coq.Structures.Equalities.
Module GLabel_as_UDT := Make_UDT GLabel_as_OT.


(********************************************************************)
(*                                                                  *)
(*  The Why3 Verification Platform   /   The Why3 Development Team  *)
(*  Copyright 2010-2019   --   Inria - CNRS - Paris-Sud University  *)
(*                                                                  *)
(*  This software is distributed under the terms of the GNU Lesser  *)
(*  General Public License version 2.1, with the special exception  *)
(*  on linking described in file LICENSE.                           *)
(*                                                                  *)
(********************************************************************)

(* This file is generated by Why3's Coq-realize driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.
Require real.Real.

(* Why3 comment *)
(* from_int is replaced with (BuiltIn.IZR x) by the coq driver *)

(* Why3 goal *)
Lemma Zero : ((BuiltIn.IZR 0%Z) = 0%R).
Proof.
split.
Qed.

(* Why3 goal *)
Lemma One : ((BuiltIn.IZR 1%Z) = 1%R).
Proof.
split.
Qed.

(* Why3 goal *)
Lemma Add :
  forall (x:Numbers.BinNums.Z) (y:Numbers.BinNums.Z),
  ((BuiltIn.IZR (x + y)%Z) = ((BuiltIn.IZR x) + (BuiltIn.IZR y))%R).
Proof.
exact plus_IZR.
Qed.

(* Why3 goal *)
Lemma Sub :
  forall (x:Numbers.BinNums.Z) (y:Numbers.BinNums.Z),
  ((BuiltIn.IZR (x - y)%Z) = ((BuiltIn.IZR x) - (BuiltIn.IZR y))%R).
Proof.
exact minus_IZR.
Qed.

(* Why3 goal *)
Lemma Mul :
  forall (x:Numbers.BinNums.Z) (y:Numbers.BinNums.Z),
  ((BuiltIn.IZR (x * y)%Z) = ((BuiltIn.IZR x) * (BuiltIn.IZR y))%R).
Proof.
exact mult_IZR.
Qed.

(* Why3 goal *)
Lemma Neg :
  forall (x:Numbers.BinNums.Z), ((BuiltIn.IZR (-x)%Z) = (-(BuiltIn.IZR x))%R).
Proof.
exact opp_IZR.
Qed.

(* Why3 goal *)
Lemma Injective :
  forall (x:Numbers.BinNums.Z) (y:Numbers.BinNums.Z),
  ((BuiltIn.IZR x) = (BuiltIn.IZR y)) -> (x = y).
Proof.
exact eq_IZR.
Qed.

(* Why3 goal *)
Lemma Monotonic :
  forall (x:Numbers.BinNums.Z) (y:Numbers.BinNums.Z), (x <= y)%Z ->
  ((BuiltIn.IZR x) <= (BuiltIn.IZR y))%R.
Proof.
exact (IZR_le).
Qed.


From Coq Require Import Eqdep_dec. (* Needed to prove decidable equality on RegName *)
From stdpp Require Import gmap fin_maps list finite.

(* We assume a fixed set of registers, and a finite set of memory addresses.

   The exact size of the address space does not matter, it could be made a
   parameter of the machine.
*)

Definition RegNum: nat := 31.
Definition MemNum: Z := 2000000.

(* ---------------------------------- Registers ----------------------------------------*)

Inductive RegName: Type :=
| PC
| R (n: nat) (fin: n <=? RegNum = true).

Global Instance reg_eq_dec : EqDecision RegName.
Proof. intros r1 r2.  destruct r1,r2; [by left | by right | by right |].
       destruct (nat_eq_dec n n0).
       + subst n0. left.
         assert (forall (b: bool) (n m: nat) (P1 P2: n <=? m = b), P1 = P2).
         { intros. apply eq_proofs_unicity.
           intros; destruct x; destruct y; auto. }
         rewrite (H _ _ _ fin fin0). reflexivity.
       + right. congruence.
Defined.

Lemma reg_eq_sym (r1 r2 : RegName) : r1 ≠ r2 → r2 ≠ r1. Proof. auto. Qed.

Program Definition n_to_regname (n : nat) : option RegName :=
  if (nat_le_dec n RegNum) then Some (R n _) else None.
Next Obligation.
  intros. eapply Nat.leb_le; eauto.
Defined.

Definition all_registers: list RegName :=
  [R 0 eq_refl; R 1 eq_refl; R 2 eq_refl; R 3 eq_refl; R 4 eq_refl; R 5 eq_refl;
   R 6 eq_refl; R 7 eq_refl; R 8 eq_refl; R 9 eq_refl; R 10 eq_refl; R 11 eq_refl;
   R 12 eq_refl; R 13 eq_refl; R 14 eq_refl; R 15 eq_refl; R 16 eq_refl; R 17 eq_refl;
   R 18 eq_refl; R 19 eq_refl; R 20 eq_refl; R 21 eq_refl; R 22 eq_refl; R 23 eq_refl;
   R 24 eq_refl; R 25 eq_refl; R 26 eq_refl; R 27 eq_refl; R 28 eq_refl; R 29 eq_refl;
   R 30 eq_refl; R 31 eq_refl; PC].

Global Instance RegName_finite: Finite RegName.
Proof.
  refine {| enum := all_registers;
            NoDup_enum := _;
            elem_of_enum := _ |}.
  { repeat (econstructor; [set_solver|]).
    econstructor. }
  { destruct x; [set_solver|].
    do 32 (destruct n as [|n]; [rewrite (@Eqdep_dec.eq_proofs_unicity bool ltac:(decide equality) _ _ fin (eq_refl _)); set_solver|]).
    simpl in fin. discriminate. }
Qed.

Global Instance reg_countable : Countable RegName.
Proof.
  refine {| encode r := encode match r with
                               | PC => inl ()
                               | R n fin => inr n
                               end ;
            decode n := match (decode n) with
                        | Some (inl ()) => Some PC
                        | Some (inr n) => n_to_regname n
                        | None => None
                        end ;
            decode_encode := _ |}.
  intro r. destruct r; auto.
  rewrite decode_encode.
  unfold n_to_regname.
  destruct (nat_le_dec n RegNum).
  - do 2 f_equal. apply eq_proofs_unicity. decide equality.
  - exfalso. by apply (Nat.leb_le n RegNum) in fin.
Defined.

(* -------------------------------- Memory addresses -----------------------------------*)

Inductive Addr: Type :=
| A (z : Z) (fin: Z.leb z MemNum = true) (pos: Z.leb 0 z = true).

Definition z_of (a: Addr): Z :=
  match a with
  | A z _ _ => z
  end.

Coercion z_of: Addr >-> Z.

Lemma z_of_eq a1 a2 :
  z_of a1 = z_of a2 ->
  a1 = a2.
Proof.
  destruct a1, a2; cbn. intros ->.
  repeat f_equal; apply eq_proofs_unicity; decide equality.
Qed.

Lemma eq_z_of a1 a2 :
  a1 = a2 ->
  z_of a1 = z_of a2.
Proof. destruct a1; destruct a2. congruence. Qed.

Lemma z_of_neq a1 a2 :
  z_of a1 <> z_of a2 ->
  a1 <> a2.
Proof. red; intros. apply H. rewrite H0; reflexivity. Qed.

Lemma neq_z_of a1 a2 :
  a1 ≠ a2 → (z_of a1) ≠ (z_of a2).
Proof. intros. intros Heq%z_of_eq. congruence. Qed.

Global Instance addr_eq_dec: EqDecision Addr.
intros x y. destruct x,y. destruct (Z_eq_dec z z0).
- left. eapply z_of_eq; eauto.
- right. inversion 1. simplify_eq.
Defined.

Definition z_to_addr (z : Z) : option Addr.
Proof.
  destruct (Z_le_dec z MemNum),(Z_le_dec 0 z).
  - apply (Z.leb_le z MemNum) in l.
    apply (Z.leb_le 0 z) in l0.
    exact (Some (A z l l0)).
  - exact None.
  - exact None.
  - exact None.
Defined.

Lemma addr_spec (a: Addr) : (a <= MemNum)%Z ∧ (0 <= a)%Z.
Proof. destruct a. cbn. rewrite Z.leb_le in fin. rewrite Z.leb_le in pos. lia. Qed.

Lemma z_to_addr_z_of (a:Addr) :
  z_to_addr a = Some a.
Proof.
  generalize (addr_spec a); intros [? ?].
  set (z := (z_of a)) in *.
  unfold z_to_addr.
  destruct (Z_le_dec z MemNum) eqn:?;
  destruct (Z_le_dec 0 z) eqn:?.
  { f_equal. apply z_of_eq. cbn. lia. }
  all: lia.
Qed.

Lemma z_to_addr_eq_inv (a b:Addr) :
  z_to_addr a = Some b → a = b.
Proof. rewrite z_to_addr_z_of. naive_solver. Qed.

Global Instance addr_countable : Countable Addr.
Proof.
  refine {| encode r := encode (z_of r) ;
            decode n := match (decode n) with
                        | Some z => z_to_addr z
                        | None => None
                        end ;
            decode_encode := _ |}.
  intro r. destruct r; auto.
  rewrite decode_encode.
  unfold z_to_addr. simpl.
  destruct (Z_le_dec z MemNum),(Z_le_dec 0 z).
  - repeat f_equal; apply eq_proofs_unicity; decide equality.
  - exfalso. by apply (Z.leb_le 0 z) in pos.
  - exfalso. by apply (Z.leb_le z MemNum) in fin.
  - exfalso. by apply (Z.leb_le z MemNum) in fin.
Defined.

Definition le_lt_addr : Addr → Addr → Addr → Prop :=
  λ a1 a2 a3, (a1 <= a2 < a3)%Z.
Definition le_addr : Addr → Addr → Prop :=
  λ a1 a2, (a1 <= a2)%Z.
Definition lt_addr : Addr → Addr → Prop :=
  λ a1 a2, (a1 < a2)%Z.
Definition leb_addr : Addr → Addr → bool :=
  λ a1 a2, Z.leb a1 a2.
Definition ltb_addr : Addr → Addr → bool :=
  λ a1 a2, Z.ltb a1 a2.
Definition eqb_addr : Addr → Addr → bool :=
  λ a1 a2, Z.eqb a1 a2.
Definition za : Addr := A 0%Z eq_refl eq_refl.
Definition top : Addr := A MemNum eq_refl eq_refl.
Delimit Scope Addr_scope with a.
Notation "a1 <= a2 < a3" := (le_lt_addr a1 a2 a3): Addr_scope.
Notation "a1 <= a2" := (le_addr a1 a2): Addr_scope.
Notation "a1 <=? a2" := (leb_addr a1 a2): Addr_scope.
Notation "a1 < a2" := (lt_addr a1 a2): Addr_scope.
Notation "a1 <? a2" := (ltb_addr a1 a2): Addr_scope.
Notation "a1 =? a2" := (eqb_addr a1 a2): Addr_scope.
Notation "0" := (za) : Addr_scope.

Global Instance Addr_le_dec : RelDecision le_addr.
Proof. intros x y. destruct x,y. destruct (Z_le_dec z z0); [by left|by right]. Defined.
Global Instance Addr_lt_dec : RelDecision lt_addr.
Proof. intros x y. destruct x,y. destruct (Z_lt_dec z z0); [by left|by right]. Defined.

Program Definition incr_addr (a: Addr) (z: Z): option Addr :=
  if (Z_le_dec (a + z)%Z MemNum) then
    if (Z_le_dec 0 (a + z)%Z) then Some (A (a + z)%Z _ _) else None else None.
Next Obligation.
  intros. apply Z.leb_le; auto.
Defined.
Next Obligation.
  intros. apply Z.leb_le; auto.
Defined.
Notation "a1 + z" := (incr_addr a1 z): Addr_scope.

Definition max (a1 a2: Addr): Addr :=
  if Addr_le_dec a1 a2 then a2 else a1.

Definition min (a1 a2: Addr): Addr :=
  if Addr_le_dec a1 a2 then a1 else a2.

Lemma min_addr_spec (a1 a2: Addr):
  exists a, min a1 a2 = a /\ (a: Z) = Z.min (a1: Z) (a2: Z).
Proof.
  exists (min a1 a2); split; auto.
  unfold min. destruct (Addr_le_dec a1 a2); unfold le_addr in *; lia.
Qed.

Ltac min_addr_as_spec a1 a2 :=
  generalize (min_addr_spec a1 a2); intros [? [? ?]];
  let ax := fresh "ax" in
  set (ax := (min a1 a2)) in *;
  clearbody ax; subst ax.

Lemma max_addr_spec (a1 a2: Addr):
  exists a, max a1 a2 = a /\ (a: Z) = Z.max (a1: Z) (a2: Z).
Proof.
  exists (max a1 a2); split; auto.
  unfold max. destruct (Addr_le_dec a1 a2); unfold le_addr in *; lia.
Qed.

Ltac max_addr_as_spec a1 a2 :=
  generalize (max_addr_spec a1 a2); intros [? [? ?]];
  let ax := fresh "ax" in
  set (ax := (max a1 a2)) in *;
  clearbody ax; subst ax.

Definition get_addr_from_option_addr : option Addr → Addr :=
  λ e_opt, match e_opt with
           | Some e => e
           | None => top%a
           end.

Notation "^ a" := (get_addr_from_option_addr a) (format "^ a", at level 1) : Addr_scope.

(** Automation *)
(*** A zify-like tactic to send arithmetic on adresses into Z ******)

Lemma incr_addr_spec (a: Addr) (z: Z) :
  (exists (a': Addr),
    (a + z)%a = Some a' /\ a + z <= MemNum /\ 0 ≤ a + z ∧ (a':Z) = a + z)%Z
  \/
  ((a + z)%a = None /\ (a + z > MemNum ∨ a + z < 0))%Z.
Proof.
  unfold incr_addr.
  destruct (Z_le_dec (a + z)%Z MemNum),(Z_le_dec 0 (a + z)%Z); [ left | right; split; auto; try lia..].
  eexists. repeat split; lia.
Qed.

Ltac incr_addr_as_spec a x :=
  generalize (incr_addr_spec a x); intros [(?&?&?&?&?)|(?&[?|?])];
  let ax := fresh "ax" in
  set (ax := (incr_addr a x)) in *;
  clearbody ax; subst ax.

Lemma Some_eq_inj A (x y: A) :
  Some x = Some y ->
  x = y.
Proof. congruence. Qed.

Ltac zify_addr_op_nonbranching_step :=
  lazymatch goal with
  | |- @eq Addr ?a ?a' =>
    apply z_of_eq
  | H : @eq Addr ?a ?a' |- _ =>
    apply eq_z_of in H
  | |- not (@eq Addr ?a ?a') =>
    apply z_of_neq
  | H : not (@eq Addr ?a ?a') |- _ =>
    apply neq_z_of in H
  | |- @eq (option Addr) (Some _) (Some _) =>
    f_equal
  | H : @eq (option Addr) (Some _) (Some _) |- _ =>
    apply Some_eq_inj in H
  | |- @eq (option Addr) (Some _) None =>
    exfalso
  | |- @eq (option Addr) None (Some _) =>
    exfalso

  (* wrapper definitions to unfold (<=, <, etc) *)
  | |- context [ le_lt_addr _ _ _ ] =>
    unfold le_lt_addr
  | H : context [ le_lt_addr _ _ _ ] |- _ =>
    unfold le_lt_addr in H
  | |- context [ le_addr _ _ ] =>
    unfold le_addr
  | H : context [ le_addr _ _ ] |- _ =>
    unfold le_addr in H
  | |- context [ leb_addr _ _ ] =>
    unfold leb_addr
  | H : context [ leb_addr _ _ ] |- _ =>
    unfold leb_addr in H
  | |- context [ lt_addr _ _ ] =>
    unfold lt_addr
  | H : context [ lt_addr _ _ ] |- _ =>
    unfold lt_addr in H
  | |- context [ ltb_addr _ _ ] =>
    unfold ltb_addr
  | H : context [ ltb_addr _ _ ] |- _ =>
    unfold ltb_addr in H
  | |- context [ eqb_addr _ _ ] =>
    unfold eqb_addr
  | H : context [ eqb_addr _ _ ] |- _ =>
    unfold eqb_addr in H
  | H : context [ min ?a1 ?a2 ] |- _ =>
    min_addr_as_spec a1 a2
  | |- context [ min ?a1 ?a2 ] =>
    min_addr_as_spec a1 a2
  | H : context [ max ?a1 ?a2 ] |- _ =>
    max_addr_as_spec a1 a2
  | |- context [ max ?a1 ?a2 ] =>
    max_addr_as_spec a1 a2
  end.

Ltac zify_addr_nonbranching_step :=
  first [ progress (cbn in *)
        | zify_addr_op_nonbranching_step ].

Ltac zify_addr_op_branching_goal_step :=
  lazymatch goal with
  | |- context [ incr_addr ?a ?x ] =>
    incr_addr_as_spec a x
  end.

Ltac zify_addr_op_branching_hyps_step :=
  lazymatch goal with
  | _ : context [ incr_addr ?a ?x ] |- _ =>
    incr_addr_as_spec a x
  end.

Ltac zify_addr_ty_step :=
  lazymatch goal with
  | a : Addr |- _ =>
    generalize (addr_spec a); intros [? ?];
    let z := fresh "z" in
    set (z := (z_of a)) in *;
    clearbody z;
    first [ clear a | revert dependent a ]
  end.

(** zify_addr **)
(* This greedily translates all the address-related terms in the goal and in the
   context. Because each (_ + _) introduces a disjunction, the number of goals
   quickly explodes if there are many (_ + _) in the context.

   The solve_addr tactic below is more clever and tries to limit the
   combinatorial explosion, but zify_addr does not. *)

Ltac zify_addr :=
  repeat (first [ zify_addr_nonbranching_step
                | zify_addr_op_branching_goal_step
                | zify_addr_op_branching_hyps_step ]);
  repeat zify_addr_ty_step; intros.

(** solve_addr *)
(* From a high-level perspective, [solve_addr] is equivalent to [zify_addr]
   followed by [lia].

   However, this gets very slow when there are many (_ + _) in the context (and
   some of those may not be relevant to prove the goal at hand), so the
   implementation is a bit more clever. Instead, we try to call [lia] as soon as
   possible to quickly terminate sub-goals than can be proved before the whole
   context gets translated. *)

Ltac zify_addr_op_goal_step :=
  first [ zify_addr_nonbranching_step
        | zify_addr_op_branching_goal_step ].

Ltac zify_addr_op_deepen :=
  zify_addr_op_branching_hyps_step;
  repeat zify_addr_nonbranching_step;
  try (
    zify_addr_op_branching_hyps_step;
    repeat zify_addr_nonbranching_step
  ).

Ltac solve_addr_close_proof :=
  repeat zify_addr_ty_step; intros;
  solve [ auto | lia | congruence ].

Ltac solve_addr :=
  intros;
  repeat zify_addr_op_goal_step;
  try solve_addr_close_proof;
  repeat (
    zify_addr_op_deepen;
    try solve_addr_close_proof
  );
  solve_addr_close_proof.

Goal forall a : Addr,
    (a + -(a + 3))%a = None.
Proof.
  intros. solve_addr.
Qed.

Goal forall (a a' b b' : Addr),
  (a + 1)%a = Some a' ->
  (b + 1)%a = Some b' ->
  (a + 0)%a = Some a.
Proof.
  intros.
  repeat zify_addr_op_goal_step.
  (* Check that we can actually terminate early before translating the whole
     context. *)
  solve_addr_close_proof.
  solve_addr_close_proof.
  solve_addr_close_proof.
Qed.

(* ------------------ *)
(* Hack: modify [zify] to make it support [Z.to_nat] (used in the definition of
   [region_size]). *)
(* TODO: remove the code below whenever we upgrade to Coq 8.11, as the issue has
   been fixed upstream starting from Coq 8.11.
*)

(* Lemma Z_of_nat_zify : forall x, Z.of_nat (Z.to_nat x) = Z.max 0 x. *)
(* Proof. *)
(*   intros x. destruct x. *)
(*   - rewrite Z2Nat.id; reflexivity. *)
(*   - rewrite Z2Nat.inj_pos. lia. *)
(*   - rewrite Z2Nat.inj_neg. lia. *)
(* Qed. *)

(* Ltac zify_nat_op_extended := *)
(*   match goal with *)
(*   | H : context [ Z.of_nat (Z.to_nat ?a) ] |- _ => rewrite (Z_of_nat_zify a) in H *)
(*   | |- context [ Z.of_nat (Z.to_nat ?a) ] => rewrite (Z_of_nat_zify a) *)
(*   | _ => zify_nat_op *)
(*   end. *)

(* Global Ltac zify_nat ::= *)
(*   repeat zify_nat_rel; repeat zify_nat_op_extended; unfold Z_of_nat' in *. *)

(* --------------------------- BASIC LEMMAS --------------------------------- *)

(** Address arithmetic *)

Lemma addr_add_0 a: (a + 0)%a = Some a.
Proof. solve_addr. Qed.

Lemma incr_addr_one_none a :
  (a + 1)%a = None ->
  a = top.
Proof. solve_addr. Qed.

Lemma incr_addr_opt_add_twice (a: Addr) (n m: Z) :
  (0 <= n)%Z ->
  (0 <= m)%Z ->
  ^(^(a + n) + m)%a = ^(a + (n + m)%Z)%a.
Proof. solve_addr. Qed.

Lemma top_le_eq a : (top <= a)%a → a = top.
Proof. solve_addr. Qed.

Lemma top_not_le_eq a : ¬ (a < top)%a → a = top.
Proof. solve_addr. Qed.

Lemma next_lt (a a' : Addr) :
  (a + 1)%a = Some a' → (a < a')%Z.
Proof. solve_addr. Qed.

Lemma next_lt_i (a a' : Addr) (i : Z) :
  (i > 0)%Z →
  (a + i)%a = Some a' → (a < a')%Z.
Proof. solve_addr. Qed.

Lemma next_le_i (a a' : Addr) (i : Z) :
  (i >= 0)%Z →
  (a + i)%a = Some a' → (a <= a')%Z.
Proof. solve_addr. Qed.

Lemma next_lt_top (a : Addr) i :
  (i > 0)%Z →
  is_Some (a + i)%a → a ≠ top.
Proof. intros ? [? ?] ?. solve_addr. Qed.

Lemma addr_next_le (a e : Addr) :
  (a < e)%Z → ∃ a', (a + 1)%a = Some a'.
Proof. intros. zify_addr; eauto. exfalso. lia. lia. Qed.

Lemma addr_next_lt (a e : Addr) :
  (a < e)%Z -> ∃ a', (a + 1)%a = Some a'.
Proof. intros. zify_addr; eauto. exfalso. lia. lia. Qed.

Lemma addr_next_lt_gt_contr (a e a' : Addr) :
  (a < e)%Z → (a + 1)%a = Some a' → (e < a')%Z → False.
Proof. solve_addr. Qed.

Lemma addr_next_lt_le (a e a' : Addr) :
  (a < e)%Z → (a + 1)%a = Some a' → (a' ≤ e)%Z.
Proof. solve_addr. Qed.

Lemma addr_abs_next (a e a' : Addr) :
  (a + 1)%a = Some a' → (a < e)%Z → (Z.abs_nat (e - a) - 1) = (Z.abs_nat (e - a')).
Proof. solve_addr. Qed.

Lemma addr_unique a a' fin fin' pos pos' :
  a = a' → A a fin pos = A a' fin' pos'.
Proof.
  intros ->. repeat f_equal; apply eq_proofs_unicity; decide equality.
Qed.

Lemma incr_addr_trans (a1 a2 a3 : Addr) (z1 z2 : Z) :
  (a1 + z1)%a = Some a2 → (a2 + z2)%a = Some a3 →
  (a1 + (z1 + z2))%a = Some a3.
Proof. solve_addr. Qed.

Lemma addr_add_assoc (a a' : Addr) (z1 z2 : Z) :
  (a + z1)%a = Some a' →
  (a + (z1 + z2))%a = (a' + z2)%a.
Proof. solve_addr. Qed.

Lemma incr_addr_le (a1 a2 a3 : Addr) (z1 z2 : Z) :
  (a1 + z1)%a = Some a2 -> (a1 + z2)%a = Some a3 -> (z1 <= z2)%Z ->
  (a2 <= a3)%Z.
Proof. solve_addr. Qed.

Lemma incr_addr_ne a i :
  i ≠ 0%Z → a ≠ top →
  ^ (a + i)%a ≠ a.
Proof. intros H1 H2. intro. apply H2. solve_addr. Qed.

Lemma incr_addr_ne_top a z a' :
  (z > 0)%Z → (a + z)%a = Some a' →
  a ≠ top.
Proof. intros. intro. solve_addr. Qed.

Lemma get_addrs_from_option_addr_comm a i k :
  (k >= 0)%Z -> (i >= 0)%Z ->
  (^(^(a + i) + k)%a) =
  (^(a + (i + k)%Z)%a).
Proof. solve_addr. Qed.

Lemma incr_addr_of_z (a a' : Addr) :
  (a + 1)%a = Some a' →
  (a + 1)%Z = a'.
Proof. solve_addr. Qed.

Lemma incr_addr_of_z_i (a a' : Addr) i :
  (a + i)%a = Some a' →
  (a + i)%Z = a'.
Proof. solve_addr. Qed.

Lemma invert_incr_addr (a1 a2: Addr) (z:Z):
      (a1 + z)%a = Some a2 → (a2 + (- z))%a = Some a1.
Proof. solve_addr. Qed.


(** * SfLib: Software Foundations Library *)
(* $Date: 2011-03-14 20:08:53 -0400 (Mon, 14 Mar 2011) $ *)
(** Here we collect together several useful definitions and theorems
    from Basics.v, List.v, Poly.v, Ind.v, and Logic.v that are not
    already in the Coq standard library.  From now on we can [Import]
    or [Export] this file, instead of cluttering our environment with
    all the examples and false starts in those files. *)
(** * From the Coq Standard Library *)
Require Omega.   (* needed for using the [omega] tactic *)
Require Export Bool.
Require Export List.
Require Export Arith.
Require Export Arith.EqNat.  (* Contains [beq_nat], among other things *)
(** * From Basics.v *)
Definition admit {T: Type} : T.  Admitted.
Require String. Open Scope string_scope.
Ltac move_to_top x :=
match reverse goal with
  | H : _ |- _ => try move x after H
end.
Tactic Notation "assert_eq" ident(x) constr(v) :=
let H := fresh in
  assert (x = v) as H by reflexivity;
  clear H.
Tactic Notation "Case_aux" ident(x) constr(name) :=
  first [
    set (x := name); move_to_top x
  | assert_eq x name; move_to_top x
  | fail 1 "because we are working on a different case" ].
Tactic Notation "Case" constr(name) := Case_aux Case name.
Tactic Notation "SCase" constr(name) := Case_aux SCase name.
Tactic Notation "SSCase" constr(name) := Case_aux SSCase name.
Tactic Notation "SSSCase" constr(name) := Case_aux SSSCase name.
Tactic Notation "SSSSCase" constr(name) := Case_aux SSSSCase name.
Tactic Notation "SSSSSCase" constr(name) := Case_aux SSSSSCase name.
Tactic Notation "SSSSSSCase" constr(name) := Case_aux SSSSSSCase name.
Tactic Notation "SSSSSSSCase" constr(name) := Case_aux SSSSSSSCase name.
Fixpoint ble_nat (n m : nat) : bool :=
match n with
  | O => true
  | S n' =>
match m with
      | O => false
      | S m' => ble_nat n' m'
end
end.
Theorem andb_true_elim1 : forall b c,
  andb b c = true -> b = true.
Proof.
  intros b c H.
  destruct b.
  Case "b = true".
    reflexivity.
  Case "b = false".
    rewrite <- H. reflexivity.  Qed.
Theorem andb_true_elim2 : forall b c,
  andb b c = true -> c = true.
Proof.
(* An exercise in Basics.v *)
Admitted.
Theorem beq_nat_sym : forall (n m : nat),
  beq_nat n m = beq_nat m n.
(* An exercise in Lists.v *)
Admitted.
(* From Poly.v *)
Notation "[ ]" := nil.
Notation "[ x , .. , y ]" := (cons x .. (cons y []) ..).
Notation "x ++ y" := (app x y)
                     (at level 60, right associativity).
(** * From Props.v *)
Inductive ev : nat -> Prop :=
  | ev_0 : ev O
  | ev_SS : forall n:nat, ev n -> ev (S (S n)).
(** * From Logic.v *)
Theorem andb_true : forall b c,
  andb b c = true -> b = true /\ c = true.
Proof.
  intros b c H.
  destruct b.
    destruct c.
      apply conj. reflexivity. reflexivity.
      inversion H.
    inversion H.  Qed.
Theorem not_eq_beq_false : forall n n' : nat,
     n <> n' ->
     beq_nat n n' = false.
Proof.
(* An exercise in Logic.v *)
Admitted.
Theorem ex_falso_quodlibet : forall (P:Prop),
  False -> P.
Proof.
  intros P contra.
  inversion contra.  Qed.
Theorem ev_not_ev_S : forall n,
  ev n -> ~ ev (S n).
Proof.
(* An exercise in Logic.v *)
Admitted.
Theorem ble_nat_true : forall n m,
  ble_nat n m = true -> n <= m.
(* An exercise in Logic.v *)
Admitted.
Theorem ble_nat_false : forall n m,
  ble_nat n m = false -> ~(n <= m).
(* An exercise in Logic.v *)
Admitted.
Inductive appears_in (n : nat) : list nat -> Prop :=
| ai_here : forall l, appears_in n (n::l)
| ai_later : forall m l, appears_in n l -> appears_in n (m::l).
Definition relation (X:Type) := X -> X -> Prop.
Definition partial_function {X: Type} (R: relation X) :=
forall x y1 y2 : X, R x y1 -> R x y2 -> y1 = y2.
Inductive next_nat (n:nat) : nat -> Prop :=
  | nn : next_nat n (S n).
Inductive total_relation : nat -> nat -> Prop :=
  tot : forall n m : nat, total_relation n m.
Inductive empty_relation : nat -> nat -> Prop := .
Inductive refl_step_closure (X:Type) (R: relation X)
                            : X -> X -> Prop :=
  | rsc_refl  : forall (x : X),
                 refl_step_closure X R x x
  | rsc_step : forall (x y z : X),
                    R x y ->
                    refl_step_closure X R y z ->
                    refl_step_closure X R x z.
Implicit Arguments refl_step_closure [[X]].
Tactic Notation "rsc_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "rsc_refl" | Case_aux c "rsc_step" ].
Theorem rsc_R : forall (X:Type) (R:relation X) (x y : X),
       R x y -> refl_step_closure R x y.
Proof.
  intros X R x y r.
  apply rsc_step with y. apply r. apply rsc_refl.   Qed.
Theorem rsc_trans :
forall (X:Type) (R: relation X) (x y z : X),
      refl_step_closure R x y  ->
      refl_step_closure R y z ->
      refl_step_closure R x z.
Proof.
  (* FILL IN HERE *) Admitted.
(* Identifiers and polymorphic partial maps. *)
Inductive id : Type :=
  Id : nat -> id.
Definition beq_id id1 id2 :=
match (id1, id2) with
    (Id n1, Id n2) => beq_nat n1 n2
end.
Theorem beq_id_refl : forall i,
  true = beq_id i i.
Proof.
  intros. destruct i.
  apply beq_nat_refl.  Qed.
Theorem beq_id_eq : forall i1 i2,
  true = beq_id i1 i2 -> i1 = i2.
Proof.
  intros i1 i2 H.
  destruct i1. destruct i2.
  apply beq_nat_eq in H. subst.
  reflexivity.  Qed.
Theorem beq_id_false_not_eq : forall i1 i2,
  beq_id i1 i2 = false -> i1 <> i2.
Proof.
  intros i1 i2 H.
  destruct i1. destruct i2.
  apply beq_nat_false in H.
  intros C. apply H. inversion C. reflexivity.  Qed.
Theorem not_eq_beq_id_false : forall i1 i2,
  i1 <> i2 -> beq_id i1 i2 = false.
Proof.
  intros i1 i2 H.
  destruct i1. destruct i2.
  assert (n <> n0).
    intros C. subst. apply H. reflexivity.
  apply not_eq_beq_false. assumption.  Qed.
Theorem beq_id_sym: forall i1 i2,
  beq_id i1 i2 = beq_id i2 i1.
Proof.
  intros i1 i2. destruct i1. destruct i2. apply beq_nat_sym. Qed.
Definition partial_map (A:Type) := id -> option A.
Definition empty {A:Type} : partial_map A := (fun _ => None).
Definition extend {A:Type} (Gamma : partial_map A) (x:id) (T : A) :=
fun x' => if beq_id x x' then Some T else Gamma x'.
Lemma extend_eq : forall A (ctxt: partial_map A) x T,
  (extend ctxt x T) x = Some T.
Proof.
  intros. unfold extend. rewrite <- beq_id_refl. auto.
Qed.
Lemma extend_neq : forall A (ctxt: partial_map A) x1 T x2,
  beq_id x2 x1 = false ->
  (extend ctxt x2 T) x1 = ctxt x1.
Proof.
  intros. unfold extend. rewrite H. auto.
Qed.
Lemma extend_shadow : forall A (ctxt: partial_map A) t1 t2 x1 x2,
  extend (extend ctxt x2 t1) x2 t2 x1 = extend ctxt x2 t2 x1.
Proof with auto.
  intros. unfold extend. destruct (beq_id x2 x1)...
Qed.
(** * Some useful tactics *)
Tactic Notation "solve_by_inversion_step" tactic(t) :=
match goal with
  | H : _ |- _ => solve [ inversion H; subst; t ]
end
  || fail "because the goal is not solvable by inversion.".
Tactic Notation "solve" "by" "inversion" "1" :=
  solve_by_inversion_step idtac.
Tactic Notation "solve" "by" "inversion" "2" :=
  solve_by_inversion_step (solve by inversion 1).
Tactic Notation "solve" "by" "inversion" "3" :=
  solve_by_inversion_step (solve by inversion 2).
Tactic Notation "solve" "by" "inversion" :=
  solve by inversion 1.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable rT_ : Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Prop.
Variable par_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable oS_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable cong_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.
Variable betS_ : Universe -> Universe -> Universe -> Prop.

Variable defsameside_1 : (forall P Q A B : Universe, (exists X U V : Universe, (oS_ P Q A B -> (col_ A B U /\ (col_ A B V /\ (betS_ P U X /\ (betS_ Q V X /\ (~(col_ A B P) /\ ~(col_ A B Q))))))))).
Variable defsameside2_2 : (forall P Q A B X U V : Universe, ((col_ A B U /\ (col_ A B V /\ (betS_ P U X /\ (betS_ Q V X /\ (~(col_ A B P) /\ ~(col_ A B Q)))))) -> oS_ P Q A B)).
Variable lemma_NCdistinct_3 : (forall A B C : Universe, (~(col_ A B C) -> (A <> B /\ (B <> C /\ (A <> C /\ (B <> A /\ (C <> B /\ C <> A))))))).
Variable lemma_inequalitysymmetric_4 : (forall A B : Universe, (A <> B -> B <> A)).
Variable lemma_extension_5 : (forall A B P Q : Universe, (exists X : Universe, ((A <> B /\ P <> Q) -> (betS_ A B X /\ cong_ B X P Q)))).
Variable axiom_betweennesssymmetry_6 : (forall A B C : Universe, (betS_ A B C -> betS_ C B A)).
Variable proposition_28B_7 : (forall A B C D G H : Universe, ((betS_ A G B /\ (betS_ C H D /\ (rT_ B G H G H D /\ oS_ B D G H))) -> par_ A B C D)).
Variable defcollinear_8 : (forall A B C : Universe, (col_ A B C -> (A = B \/ (A = C \/ (B = C \/ (betS_ B A C \/ (betS_ A B C \/ betS_ A C B))))))).
Variable defcollinear2a_9 : (forall A B C : Universe, (A = B -> col_ A B C)).
Variable defcollinear2b_10 : (forall A B C : Universe, (A = C -> col_ A B C)).
Variable defcollinear2c_11 : (forall A B C : Universe, (B = C -> col_ A B C)).
Variable defcollinear2d_12 : (forall A B C : Universe, (betS_ B A C -> col_ A B C)).
Variable defcollinear2e_13 : (forall A B C : Universe, (betS_ A B C -> col_ A B C)).
Variable defcollinear2f_14 : (forall A B C : Universe, (betS_ A C B -> col_ A B C)).
Variable lemma_collinearorder_15 : (forall A B C : Universe, (col_ A B C -> (col_ B A C /\ (col_ B C A /\ (col_ C A B /\ (col_ A C B /\ col_ C B A)))))).
Variable lemma_collinearparallel_16 : (forall A B C Xc Xd : Universe, ((par_ A B Xc Xd /\ (col_ Xc Xd C /\ C <> Xd)) -> par_ A B C Xd)).
Variable lemma_parallelsymmetric_17 : (forall A B C D : Universe, (par_ A B C D -> par_ C D A B)).

Theorem proposition_28C_18 : (forall B D G H : Universe, ((rT_ B G H G H D /\ oS_ B D G H) -> par_ G B H D)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Export List.
Require Export Bool.
Require Export Arith.
Require Export Peano_dec.
Require Export Coq.Arith.PeanoNat.
Require Export Coq.Program.Wf.
Require Export Coq.Program.Tactics.
Require Export Coq.Logic.FunctionalExtensionality.
Require Export Recdef.

Require Import common.CpdtTactics.
Require Import common.wyv_common.
Require Import common.rhs_mat_tree.

Require Export common.lhs_con_reduce.rhs_con_reduce.
Require Export common.lhs_con_reduce.rhs_nil_reduce.
Require Export common.lhs_con_reduce.rhs_other_reduce.
Set Implicit Arguments.

Import WfExtensionality.

Lemma subtype_con_reduce :
  forall T1 T1' Ts1, T1 = t_con T1' Ts1 ->
                forall T2, subtype T1 T2 = match T2 with
                                      | t_nil => true
                                      | t_con T2' Ts2 => (subtype T1' T2') && (subtype Ts1 Ts2)
                                      | _ => false
                                      end.
Proof.
  intros; subst; destruct T2;
    try solve [eapply subtype_con_other_reduce; crush].

  eapply subtype_con_nil_reduce; auto.
  eapply subtype_con_con_reduce; auto.
Qed.